;;; index leaving the loop range)
(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
+;;; A couple of VM-related types that are currently used only on the
+;;; alpha platform. -- CSR, 2002-06-24
+(def!type unsigned-byte-with-a-bite-out (s bite)
+ (cond ((eq s '*) 'integer)
+ ((and (integerp s) (> s 0))
+ (let ((bound (ash 1 s)))
+ `(integer 0 ,(- bound bite 1))))
+ (t
+ (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s))))
+
+;;; Motivated by the mips port. -- CSR, 2002-08-22
+(def!type signed-byte-with-a-bite-out (s bite)
+ (cond ((eq s '*) 'integer)
+ ((and (integerp s) (> s 1))
+ (let ((bound (ash 1 (1- s))))
+ `(integer ,(- bound) ,(- bound bite 1))))
+ (t
+ (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+
+(def!type load/store-index (scale lowtag min-offset
+ &optional (max-offset min-offset))
+ `(integer ,(- (truncate (+ (ash 1 16)
+ (* min-offset sb!vm:n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+ (* max-offset sb!vm:n-word-bytes))
+ scale)))
+
+;;; Similar to FUNCTION, but the result type is "exactly" specified:
+;;; if it is an object type, then the function returns exactly one
+;;; value, if it is a short form of VALUES, then this short form
+;;; specifies the exact number of values.
+(def!type sfunction (args &optional result)
+ (let ((result (cond ((eq result '*) '*)
+ ((or (atom result)
+ (not (eq (car result) 'values)))
+ `(values ,result &optional))
+ ((intersection (cdr result) lambda-list-keywords)
+ result)
+ (t `(values ,@(cdr result) &optional)))))
+ `(function ,args ,result)))
+
+;;; a type specifier
+;;;
+;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS.
+;;; However, the CL:CLASS type is only defined once PCL is loaded,
+;;; which is before this is evaluated. Once PCL is moved into cold
+;;; init, this might be fixable.
+(def!type type-specifier () '(or list symbol sb!kernel:instance))
+
;;; the default value used for initializing character data. The ANSI
;;; spec says this is arbitrary, so we use the value that falls
;;; through when we just let the low-level consing code initialize
\f
;;;; type-ish predicates
-;;; a helper function for various macros which expect clauses of a
-;;; given length, etc.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; Return true if X is a proper list whose length is between MIN and
- ;; MAX (inclusive).
- (defun proper-list-of-length-p (x min &optional (max min))
- ;; FIXME: This implementation will hang on circular list
- ;; structure. Since this is an error-checking utility, i.e. its
- ;; job is to deal with screwed-up input, it'd be good style to fix
- ;; it so that it can deal with circular list structure.
- (cond ((minusp max)
- nil)
- ((null x)
- (zerop min))
- ((consp x)
- (and (plusp max)
- (proper-list-of-length-p (cdr x)
- (if (plusp (1- min))
- (1- min)
- 0)
- (1- max))))
- (t nil))))
-
;;; Is X a list containing a cycle?
(defun cyclic-list-p (x)
(and (listp x)
(and (consp x)
(list-of-length-at-least-p (cdr x) (1- n)))))
+(declaim (inline singleton-p))
+(defun singleton-p (list)
+ (and (consp list)
+ (null (rest list))))
+
;;; Is X is a positive prime integer?
(defun positive-primep (x)
;; This happens to be called only from one place in sbcl-0.7.0, and
;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
;;; is the pointer to the current tail of the list, or NIL if the list
;;; is empty.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun collect-normal-expander (n-value fun forms)
`(progn
,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
;; just define ASSQ explicitly in terms of more primitive
;; operations:
(dolist (pair alist)
- (when (eq (car pair) item)
+ ;; though it may look more natural to write this as
+ ;; (AND PAIR (EQ (CAR PAIR) ITEM))
+ ;; the temptation to do so should be resisted, as pointed out by PFD
+ ;; sbcl-devel 2003-08-16, as NIL elements are rare in association
+ ;; lists. -- CSR, 2003-08-16
+ (when (and (eq (car pair) item) (not (null pair)))
(return pair))))
;;; like (DELETE .. :TEST #'EQ):
(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
(defun nth-but-with-sane-arg-order (list index)
(nth index list))
+
+(defun adjust-list (list length initial-element)
+ (let ((old-length (length list)))
+ (cond ((< old-length length)
+ (append list (make-list (- length old-length)
+ :initial-element initial-element)))
+ ((> old-length length)
+ (subseq list 0 length))
+ (t list))))
\f
;;;; miscellaneous iteration extensions
-;;; "the ultimate iteration macro"
+;;; "the ultimate iteration macro"
;;;
;;; note for Schemers: This seems to be identical to Scheme's "named LET".
(defmacro named-let (name binds &body body)
;;; Iterate over the entries in a HASH-TABLE.
(defmacro dohash ((key-var value-var table &optional result) &body body)
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(let ((gen (gensym))
(n-more (gensym)))
`(with-hash-table-iterator (,gen ,table)
,@(values-names))
(values ,@(values-names)))
(values ,@(values-names))))))))))))
+
+(defmacro define-cached-synonym
+ (name &optional (original (symbolicate "%" name)))
+ (let ((cached-name (symbolicate "%%" name "-cached")))
+ `(progn
+ (defun-cached (,cached-name :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((args equal))
+ (apply #',original args))
+ (defun ,name (&rest args)
+ (,cached-name args)))))
+
+;;; FIXME: maybe not the best place
+;;;
+;;; FIXME: think of a better name -- not only does this not have the
+;;; CAR recursion of EQUAL, it also doesn't have the special treatment
+;;; of pathnames, bit-vectors and strings.
+;;;
+;;; KLUDGE: This means that we will no longer cache specifiers of the
+;;; form '(INTEGER (0) 4). This is probably not a disaster.
+;;;
+;;; A helper function for the type system, which is the main user of
+;;; these caches: we must be more conservative than EQUAL for some of
+;;; our equality tests, because MEMBER and friends refer to EQLity.
+;;; So:
+(defun equal-but-no-car-recursion (x y)
+ (cond
+ ((eql x y) t)
+ ((consp x)
+ (and (consp y)
+ (eql (car x) (car y))
+ (equal-but-no-car-recursion (cdr x) (cdr y))))
+ (t nil)))
\f
;;;; package idioms
;;; Is NAME a legal function name?
(defun legal-fun-name-p (name)
- (or (symbolp name)
- (and (consp name)
- (eq (car name) 'setf)
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))))
-
-;;; Given a function name, return the name for the BLOCK which
-;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
+ (values (valid-function-name-p name)))
+
+;;; Signal an error unless NAME is a legal function name.
+(defun legal-fun-name-or-type-error (name)
+ (unless (legal-fun-name-p name)
+ (error 'simple-type-error
+ :datum name
+ :expected-type '(or symbol list)
+ :format-control "invalid function name: ~S"
+ :format-arguments (list name))))
+
+;;; Given a function name, return the symbol embedded in it.
+;;;
+;;; The ordinary use for this operator (and the motivation for the
+;;; name of this operator) is to convert from a function name to the
+;;; name of the BLOCK which encloses its body.
+;;;
+;;; Occasionally the operator is useful elsewhere, where the operator
+;;; name is less mnemonic. (Maybe it should be changed?)
(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name))
(defun fun-name-block-name (fun-name)
(cond ((symbolp fun-name)
fun-name)
- ((and (consp fun-name)
- (= (length fun-name) 2)
- (eq (first fun-name) 'setf))
- (second fun-name))
+ ((consp fun-name)
+ (multiple-value-bind (legalp block-name)
+ (valid-function-name-p fun-name)
+ (if legalp
+ block-name
+ (error "not legal as a function name: ~S" fun-name))))
(t
(error "not legal as a function name: ~S" fun-name))))
(error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG?
:value value
:expected-type type
- :format-string "~@<~S ~_is not a ~_~S~:>"
+ :format-control "~@<~S ~_is not a ~_~S~:>"
:format-arguments (list value type)))
\f
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (gensym)))
-
;;; Return a function like FUN, but expecting its (two) arguments in
;;; the opposite order that FUN does.
(declaim (inline swapped-args-fun))
\f
;;;; utilities for two-VALUES predicates
+(defmacro not/type (x)
+ (let ((val (gensym "VAL"))
+ (win (gensym "WIN")))
+ `(multiple-value-bind (,val ,win)
+ ,x
+ (if ,win
+ (values (not ,val) t)
+ (values nil nil)))))
+
+(defmacro and/type (x y)
+ `(multiple-value-bind (val1 win1) ,x
+ (if (and (not val1) win1)
+ (values nil t)
+ (multiple-value-bind (val2 win2) ,y
+ (if (and val1 val2)
+ (values t t)
+ (values nil (and win2 (not val2))))))))
+
;;; sort of like ANY and EVERY, except:
;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
(warn "using deprecated ~S~@[, should use ~S instead~]"
bad-name
good-name))
+
+;;; Anaphoric macros
+(defmacro awhen (test &body body)
+ `(let ((it ,test))
+ (when it ,@body)))
+
+(defmacro acond (&rest clauses)
+ (if (null clauses)
+ `()
+ (destructuring-bind ((test &body body) &rest rest) clauses
+ (once-only ((test test))
+ `(if ,test
+ (let ((it ,test)) (declare (ignorable it)),@body)
+ (acond ,@rest))))))
+
+;;; (binding* ({(name initial-value [flag])}*) body)
+;;; FLAG may be NIL or :EXIT-IF-NULL
+;;;
+;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN.
+(defmacro binding* ((&rest bindings) &body body)
+ (let ((bindings (reverse bindings)))
+ (loop with form = `(progn ,@body)
+ for binding in bindings
+ do (destructuring-bind (names initial-value &optional flag)
+ binding
+ (multiple-value-bind (names declarations)
+ (etypecase names
+ (null
+ (let ((name (gensym)))
+ (values (list name) `((declare (ignorable ,name))))))
+ (symbol
+ (values (list names) nil))
+ (list
+ (values names nil)))
+ (setq form `(multiple-value-bind ,names
+ ,initial-value
+ ,@declarations
+ ,(ecase flag
+ ((nil) form)
+ ((:exit-if-null)
+ `(when ,(first names) ,form)))))))
+ finally (return form))))
+\f
+;;; Delayed evaluation
+(defmacro delay (form)
+ `(cons nil (lambda () ,form)))
+
+(defun force (promise)
+ (cond ((not (consp promise)) promise)
+ ((car promise) (cdr promise))
+ (t (setf (car promise) t
+ (cdr promise) (funcall (cdr promise))))))
+
+(defun promise-ready-p (promise)
+ (or (not (consp promise))
+ (car promise)))
+\f
+;;; toplevel helper
+(defmacro with-rebound-io-syntax (&body body)
+ `(%with-rebound-io-syntax (lambda () ,@body)))
+
+(defun %with-rebound-io-syntax (function)
+ (declare (type function function))
+ (let ((*package* *package*)
+ (*print-array* *print-array*)
+ (*print-base* *print-base*)
+ (*print-case* *print-case*)
+ (*print-circle* *print-circle*)
+ (*print-escape* *print-escape*)
+ (*print-gensym* *print-gensym*)
+ (*print-length* *print-length*)
+ (*print-level* *print-level*)
+ (*print-lines* *print-lines*)
+ (*print-miser-width* *print-miser-width*)
+ (*print-pretty* *print-pretty*)
+ (*print-radix* *print-radix*)
+ (*print-readably* *print-readably*)
+ (*print-right-margin* *print-right-margin*)
+ (*read-base* *read-base*)
+ (*read-default-float-format* *read-default-float-format*)
+ (*read-eval* *read-eval*)
+ (*read-suppress* *read-suppress*)
+ (*readtable* *readtable*))
+ (funcall function)))
projects / sbcl.git / blobdiff