(in-package "SB!IMPL")
+(defvar *core-pathname* nil
+ #!+sb-doc
+ "The absolute pathname of the running SBCL core.")
+
+(defvar *runtime-pathname* nil
+ #!+sb-doc
+ "The absolute pathname of the running SBCL runtime.")
+
;;; something not EQ to anything we might legitimately READ
(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
-;;; a type used for indexing into arrays, and for related quantities
-;;; like lengths of lists
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant max-hash sb!xc:most-positive-fixnum))
+
+(def!type hash ()
+ `(integer 0 ,max-hash))
+
+;;; a type used for indexing into sequences, and for related
+;;; quantities like lengths of lists and other sequences.
;;;
-;;; It's intentionally limited to one less than the
-;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
-;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
-;;; that lets the system know it can increment a value of this type
-;;; without having to worry about using a bignum to represent the
-;;; result.
+;;; A more correct value for the exclusive upper bound for indexing
+;;; would be (1- ARRAY-DIMENSION-LIMIT) since ARRAY-DIMENSION-LIMIT is
+;;; the exclusive maximum *size* of one array dimension (As specified
+;;; in CLHS entries for MAKE-ARRAY and "valid array dimensions"). The
+;;; current value is maintained to avoid breaking existing code that
+;;; also uses that type for upper bounds on indices (e.g. sequence
+;;; length).
;;;
-;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
-;;; bound because ANSI specifies it as an exclusive bound.)
+;;; In SBCL, ARRAY-DIMENSION-LIMIT is arranged to be a little smaller
+;;; than MOST-POSITIVE-FIXNUM, for implementation (see comment above
+;;; ARRAY-DIMENSION-LIMIT) and efficiency reasons: staying below
+;;; MOST-POSITIVE-FIXNUM lets the system know it can increment a value
+;;; of type INDEX without having to worry about using a bignum to
+;;; represent the result.
(def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
+;;; like INDEX, but only up to half the maximum. Used by hash-table
+;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))).
+(def!type index/2 () `(integer 0 (,(floor sb!xc:array-dimension-limit 2))))
+
;;; like INDEX, but augmented with -1 (useful when using the index
;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with
;;; an implementation which terminates the loop by testing for the
;;; 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))))
+ ((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))
+ &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)))
+ (* min-offset sb!vm:n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+ (* max-offset sb!vm:n-word-bytes))
+ scale)))
+
+#!+(or x86 x86-64)
+(defun displacement-bounds (lowtag element-size data-offset)
+ (let* ((adjustment (- (* data-offset sb!vm:n-word-bytes) lowtag))
+ (bytes-per-element (ceiling element-size sb!vm:n-byte-bits))
+ (min (truncate (+ sb!vm::minimum-immediate-offset adjustment)
+ bytes-per-element))
+ (max (truncate (+ sb!vm::maximum-immediate-offset adjustment)
+ bytes-per-element)))
+ (values min max)))
+
+#!+(or x86 x86-64)
+(def!type constant-displacement (lowtag element-size data-offset)
+ (flet ((integerify (x)
+ (etypecase x
+ (integer x)
+ (symbol (symbol-value x)))))
+ (let ((lowtag (integerify lowtag))
+ (element-size (integerify element-size))
+ (data-offset (integerify data-offset)))
+ (multiple-value-bind (min max) (displacement-bounds lowtag
+ element-size
+ data-offset)
+ `(integer ,min ,max)))))
+
+;;; 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) sb!xc: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
\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)
+;;; X may contain cycles -- a conservative approximation. This
+;;; occupies a somewhat uncomfortable niche between being fast for
+;;; common cases (we don't want to allocate a hash-table), and not
+;;; falling down to exponential behaviour for large trees (so we set
+;;; an arbitrady depth limit beyond which we punt).
+(defun maybe-cyclic-p (x &optional (depth-limit 12))
(and (listp x)
- (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
- (do ((y x (safe-cddr y))
- (started-p nil t)
- (z x (cdr z)))
- ((not (and (consp z) (consp y))) nil)
- (when (and started-p (eq y z))
- (return t))))))
+ (labels ((safe-cddr (cons)
+ (let ((cdr (cdr cons)))
+ (when (consp cdr)
+ (cdr cdr))))
+ (check-cycle (object seen depth)
+ (when (and (consp object)
+ (or (> depth depth-limit)
+ (member object seen)
+ (circularp object seen depth)))
+ (return-from maybe-cyclic-p t)))
+ (circularp (list seen depth)
+ ;; Almost regular circular list detection, with a twist:
+ ;; we also check each element of the list for upward
+ ;; references using CHECK-CYCLE.
+ (do ((fast (cons (car list) (cdr list)) (safe-cddr fast))
+ (slow list (cdr slow)))
+ ((not (consp fast))
+ ;; Not CDR-circular, need to check remaining CARs yet
+ (do ((tail slow (and (cdr tail))))
+ ((not (consp tail))
+ nil)
+ (check-cycle (car tail) (cons tail seen) (1+ depth))))
+ (check-cycle (car slow) (cons slow seen) (1+ depth))
+ (when (eq fast slow)
+ (return t)))))
+ (circularp x (list x) 0))))
;;; Is X a (possibly-improper) list of at least N elements?
(declaim (ftype (function (t index)) list-of-length-at-least-p))
(defun list-of-length-at-least-p (x n)
(or (zerop n) ; since anything can be considered an improper list of length 0
(and (consp x)
- (list-of-length-at-least-p (cdr x) (1- n)))))
+ (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?
+;;; 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
;; only for fixnums, we can limit it to fixnums for efficiency. (And
(if (<= x 5)
(and (>= x 2) (/= x 4))
(and (not (evenp x))
- (not (zerop (rem x 3)))
- (do ((q 6)
- (r 1)
- (inc 2 (logxor inc 6)) ;; 2,4,2,4...
- (d 5 (+ d inc)))
- ((or (= r 0) (> d q)) (/= r 0))
- (declare (fixnum inc))
- (multiple-value-setq (q r) (truncate x d))))))
+ (not (zerop (rem x 3)))
+ (do ((q 6)
+ (r 1)
+ (inc 2 (logxor inc 6)) ;; 2,4,2,4...
+ (d 5 (+ d inc)))
+ ((or (= r 0) (> d q)) (/= r 0))
+ (declare (fixnum inc))
+ (multiple-value-setq (q r) (truncate x d))))))
;;; Could this object contain other objects? (This is important to
;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
(defun compound-object-p (x)
(or (consp x)
- (typep x 'instance)
+ (%instancep x)
(typep x '(array t *))))
\f
;;;; the COLLECT macro
;;; 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)
(defun collect-list-expander (n-value n-tail forms)
(let ((n-res (gensym)))
`(progn
- ,@(mapcar (lambda (form)
- `(let ((,n-res (cons ,form nil)))
- (cond (,n-tail
- (setf (cdr ,n-tail) ,n-res)
- (setq ,n-tail ,n-res))
- (t
- (setq ,n-tail ,n-res ,n-value ,n-res)))))
- forms)
- ,n-value))))
+ ,@(mapcar (lambda (form)
+ `(let ((,n-res (cons ,form nil)))
+ (cond (,n-tail
+ (setf (cdr ,n-tail) ,n-res)
+ (setq ,n-tail ,n-res))
+ (t
+ (setq ,n-tail ,n-res ,n-value ,n-res)))))
+ forms)
+ ,n-value))))
;;; Collect some values somehow. Each of the collections specifies a
;;; bunch of things which collected during the evaluation of the body
;;; in the functional position, including macros and lambdas.
(defmacro collect (collections &body body)
(let ((macros ())
- (binds ()))
+ (binds ()))
(dolist (spec collections)
(unless (proper-list-of-length-p spec 1 3)
- (error "malformed collection specifier: ~S" spec))
+ (error "malformed collection specifier: ~S" spec))
(let* ((name (first spec))
- (default (second spec))
- (kind (or (third spec) 'collect))
- (n-value (gensym (concatenate 'string
- (symbol-name name)
- "-N-VALUE-"))))
- (push `(,n-value ,default) binds)
- (if (eq kind 'collect)
- (let ((n-tail (gensym (concatenate 'string
- (symbol-name name)
- "-N-TAIL-"))))
- (if default
- (push `(,n-tail (last ,n-value)) binds)
- (push n-tail binds))
- (push `(,name (&rest args)
- (collect-list-expander ',n-value ',n-tail args))
- macros))
- (push `(,name (&rest args)
- (collect-normal-expander ',n-value ',kind args))
- macros))))
+ (default (second spec))
+ (kind (or (third spec) 'collect))
+ (n-value (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-VALUE-"))))
+ (push `(,n-value ,default) binds)
+ (if (eq kind 'collect)
+ (let ((n-tail (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-TAIL-"))))
+ (if default
+ (push `(,n-tail (last ,n-value)) binds)
+ (push n-tail binds))
+ (push `(,name (&rest args)
+ (collect-list-expander ',n-value ',n-tail args))
+ macros))
+ (push `(,name (&rest args)
+ (collect-normal-expander ',n-value ',kind args))
+ macros))))
`(macrolet ,macros (let* ,(nreverse binds) ,@body))))
\f
;;;; some old-fashioned functions. (They're not just for old-fashioned
;; 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):
(defun delq (item list)
(let ((list list))
(do ((x list (cdr x))
- (splice '()))
- ((endp x) list)
+ (splice '()))
+ ((endp x) list)
(cond ((eq item (car x))
- (if (null splice)
- (setq list (cdr x))
- (rplacd splice (cdr x))))
- (t (setq splice x)))))) ; Move splice along to include element.
+ (if (null splice)
+ (setq list (cdr x))
+ (rplacd splice (cdr x))))
+ (t (setq splice x)))))) ; Move splice along to include element.
;;; like (POSITION .. :TEST #'EQ):
;;; not really an old-fashioned function, but what the calling
;;; convention should've been: like NTH, but with the same argument
-;;; order as in all the other dereferencing functions, with the
-;;; collection first and the index second
+;;; order as in all the other indexed dereferencing functions, with
+;;; the collection first and the index second
(declaim (inline nth-but-with-sane-arg-order))
(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"
+;;; like Scheme's named LET
;;;
-;;; note for Schemers: This seems to be identical to Scheme's "named LET".
+;;; (CMU CL called this ITERATE, and commented it as "the ultimate
+;;; iteration macro...". I (WHN) found the old name insufficiently
+;;; specific to remind me what the macro means, so I renamed it.)
(defmacro named-let (name binds &body body)
- #!+sb-doc
(dolist (x binds)
(unless (proper-list-of-length-p x 2)
(error "malformed NAMED-LET variable spec: ~S" x)))
`(labels ((,name ,(mapcar #'first binds) ,@body))
(,name ,@(mapcar #'second binds))))
+(defun filter-dolist-declarations (decls)
+ (mapcar (lambda (decl)
+ `(declare ,@(remove-if
+ (lambda (clause)
+ (and (consp clause)
+ (or (eq (car clause) 'type)
+ (eq (car clause) 'ignore))))
+ (cdr decl))))
+ decls))
;;; just like DOLIST, but with one-dimensional arrays
-(defmacro dovector ((elt vector &optional result) &rest forms)
- (let ((index (gensym))
- (length (gensym))
- (vec (gensym)))
- `(let ((,vec ,vector))
- (declare (type vector ,vec))
- (do ((,index 0 (1+ ,index))
- (,length (length ,vec)))
- ((>= ,index ,length) ,result)
- (let ((,elt (aref ,vec ,index)))
- ,@forms)))))
-
-;;; 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)
- (let ((gen (gensym))
- (n-more (gensym)))
- `(with-hash-table-iterator (,gen ,table)
- (loop
- (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
- ,@decls
- (unless ,n-more (return ,result))
- ,@forms))))))
+(defmacro dovector ((elt vector &optional result) &body body)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (with-unique-names (index length vec)
+ `(let ((,vec ,vector))
+ (declare (type vector ,vec))
+ (do ((,index 0 (1+ ,index))
+ (,length (length ,vec)))
+ ((>= ,index ,length) (let ((,elt nil))
+ ,@(filter-dolist-declarations decls)
+ ,elt
+ ,result))
+ (let ((,elt (aref ,vec ,index)))
+ ,@decls
+ (tagbody
+ ,@forms)))))))
+
+;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock
+;;; if the table is a synchronized table.
+(defmacro dohash (((key-var value-var) table &key result locked) &body body)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (with-unique-names (gen n-more n-table)
+ (let ((iter-form `(with-hash-table-iterator (,gen ,n-table)
+ (loop
+ (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
+ ,@decls
+ (unless ,n-more (return ,result))
+ ,@forms)))))
+ `(let ((,n-table ,table))
+ ,(if locked
+ `(with-locked-system-table (,n-table)
+ ,iter-form)
+ iter-form))))))
+
+;;; Executes BODY for all entries of PLIST with KEY and VALUE bound to
+;;; the respective keys and values.
+(defmacro doplist ((key val) plist &body body)
+ (with-unique-names (tail)
+ `(let ((,tail ,plist) ,key ,val)
+ (loop (when (null ,tail) (return nil))
+ (setq ,key (pop ,tail))
+ (when (null ,tail)
+ (error "malformed plist, odd number of elements"))
+ (setq ,val (pop ,tail))
+ (progn ,@body)))))
+
\f
;;;; hash cache utility
;;; its first arg, but need not return any particular value.
;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
;;;
+;;; This code used to store all the arguments / return values directly
+;;; in the cache vector. This was both interrupt- and thread-unsafe, since
+;;; it was possible that *-CACHE-ENTER would scribble over a region of the
+;;; cache vector which *-CACHE-LOOKUP had only partially processed. Instead
+;;; we now store the contents of each cache bucket as a separate array, which
+;;; is stored in the appropriate cell in the cache vector. A new bucket array
+;;; is created every time *-CACHE-ENTER is called, and the old ones are never
+;;; modified. This means that *-CACHE-LOOKUP will always work with a set
+;;; of consistent data. The overhead caused by consing new buckets seems to
+;;; be insignificant on the grand scale of things. -- JES, 2006-11-02
+;;;
;;; NAME is used to define these functions:
;;; <name>-CACHE-LOOKUP Arg*
;;; See whether there is an entry for the specified ARGs in the
;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
;;; in type system definitions so that caches will be created
;;; before top level forms run.)
-(defmacro define-hash-cache (name args &key hash-function hash-bits default
- (init-wrapper 'progn)
- (values 1))
- (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
- (nargs (length args))
- (entry-size (+ nargs values))
- (size (ash 1 hash-bits))
- (total-size (* entry-size size))
- (default-values (if (and (consp default) (eq (car default) 'values))
- (cdr default)
- (list default)))
- (n-index (gensym))
- (n-cache (gensym)))
+(defvar *cache-vector-symbols* nil)
+(defun drop-all-hash-caches ()
+ (dolist (name *cache-vector-symbols*)
+ (set name nil)))
+
+(defmacro define-hash-cache (name args &key hash-function hash-bits default
+ (init-wrapper 'progn)
+ (values 1))
+ (let* ((var-name (symbolicate "**" name "-CACHE-VECTOR**"))
+ (probes-name (when *profile-hash-cache*
+ (symbolicate "**" name "-CACHE-PROBES**")))
+ (misses-name (when *profile-hash-cache*
+ (symbolicate "**" name "-CACHE-MISSES**")))
+ (nargs (length args))
+ (size (ash 1 hash-bits))
+ (default-values (if (and (consp default) (eq (car default) 'values))
+ (cdr default)
+ (list default)))
+ (args-and-values (sb!xc:gensym "ARGS-AND-VALUES"))
+ (args-and-values-size (+ nargs values))
+ (n-index (sb!xc:gensym "INDEX"))
+ (n-cache (sb!xc:gensym "CACHE")))
+ (declare (ignorable probes-name misses-name))
(unless (= (length default-values) values)
(error "The number of default values ~S differs from :VALUES ~W."
- default values))
+ default values))
(collect ((inlines)
- (forms)
- (inits)
- (tests)
- (sets)
- (arg-vars)
- (values-indices)
- (values-names))
+ (forms)
+ (inits)
+ (sets)
+ (tests)
+ (arg-vars)
+ (values-refs)
+ (values-names))
(dotimes (i values)
- (values-indices `(+ ,n-index ,(+ nargs i)))
- (values-names (gensym)))
+ (let ((name (sb!xc:gensym "VALUE")))
+ (values-names name)
+ (values-refs `(svref ,args-and-values (+ ,nargs ,i)))
+ (sets `(setf (svref ,args-and-values (+ ,nargs ,i)) ,name))))
(let ((n 0))
(dolist (arg args)
(unless (= (length arg) 2)
(let ((arg-name (first arg))
(test (second arg)))
(arg-vars arg-name)
- (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
- (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
+ (tests `(,test (svref ,args-and-values ,n) ,arg-name))
+ (sets `(setf (svref ,args-and-values ,n) ,arg-name)))
(incf n)))
(when *profile-hash-cache*
- (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
- (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
- (inits `(setq ,n-probe 0))
- (inits `(setq ,n-miss 0))
- (forms `(defvar ,n-probe))
- (forms `(defvar ,n-miss))
- (forms `(declaim (fixnum ,n-miss ,n-probe)))))
+ (inits `(setq ,probes-name 0))
+ (inits `(setq ,misses-name 0))
+ (forms `(declaim (fixnum ,probes-name ,misses-name))))
(let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
- (inlines fun-name)
- (forms
- `(defun ,fun-name ,(arg-vars)
- ,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
- (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
- (,n-cache ,var-name))
- (declare (type fixnum ,n-index))
- (cond ((and ,@(tests))
- (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
- (values-indices))))
- (t
- ,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
- ,default))))))
+ (inlines fun-name)
+ (forms
+ `(defun ,fun-name ,(arg-vars)
+ ,@(when *profile-hash-cache*
+ `((incf ,probes-name)))
+ (flet ((miss ()
+ ,@(when *profile-hash-cache*
+ `((incf ,misses-name)))
+ (return-from ,fun-name ,default)))
+ (let* ((,n-index (,hash-function ,@(arg-vars)))
+ (,n-cache (or ,var-name (miss)))
+ (,args-and-values (svref ,n-cache ,n-index)))
+ (cond ((and (not (eql 0 ,args-and-values))
+ ,@(tests))
+ (values ,@(values-refs)))
+ (t
+ (miss))))))))
(let ((fun-name (symbolicate name "-CACHE-ENTER")))
- (inlines fun-name)
- (forms
- `(defun ,fun-name (,@(arg-vars) ,@(values-names))
- (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
- (,n-cache ,var-name))
- (declare (type fixnum ,n-index))
- ,@(sets)
- ,@(mapcar (lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
- (values-indices)
- (values-names))
- (values)))))
+ (inlines fun-name)
+ (forms
+ `(defun ,fun-name (,@(arg-vars) ,@(values-names))
+ (let ((,n-index (,hash-function ,@(arg-vars)))
+ (,n-cache (or ,var-name
+ (setq ,var-name (make-array ,size :initial-element 0))))
+ (,args-and-values (make-array ,args-and-values-size)))
+ ,@(sets)
+ (setf (svref ,n-cache ,n-index) ,args-and-values))
+ (values))))
(let ((fun-name (symbolicate name "-CACHE-CLEAR")))
- (forms
- `(defun ,fun-name ()
- (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
- (,n-cache ,var-name))
- ((minusp ,n-index))
- (declare (type fixnum ,n-index))
- ,@(collect ((arg-sets))
- (dotimes (i nargs)
- (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
- (arg-sets))
- ,@(mapcar (lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
- (values-indices)
- default-values))
- (values)))
- (forms `(,fun-name)))
-
- (inits `(unless (boundp ',var-name)
- (setq ,var-name (make-array ,total-size))))
+ (forms
+ `(defun ,fun-name ()
+ (setq ,var-name nil))))
+
+ ;; Needed for cold init!
+ (inits `(setq ,var-name nil))
#!+sb-show (inits `(setq *hash-caches-initialized-p* t))
`(progn
- (defvar ,var-name)
- (declaim (type (simple-vector ,total-size) ,var-name))
- #!-sb-fluid (declaim (inline ,@(inlines)))
- (,init-wrapper ,@(inits))
- ,@(forms)
- ',name))))
+ (pushnew ',var-name *cache-vector-symbols*)
+ (defglobal ,var-name nil)
+ ,@(when *profile-hash-cache*
+ `((defglobal ,probes-name 0)
+ (defglobal ,misses-name 0)))
+ (declaim (type (or null (simple-vector ,size)) ,var-name))
+ #!-sb-fluid (declaim (inline ,@(inlines)))
+ (,init-wrapper ,@(inits))
+ ,@(forms)
+ ',name))))
;;; some syntactic sugar for defining a function whose values are
;;; cached by DEFINE-HASH-CACHE
(defmacro defun-cached ((name &rest options &key (values 1) default
- &allow-other-keys)
- args &body body-decls-doc)
+ &allow-other-keys)
+ args &body body-decls-doc)
(let ((default-values (if (and (consp default) (eq (car default) 'values))
- (cdr default)
- (list default)))
- (arg-names (mapcar #'car args)))
- (collect ((values-names))
- (dotimes (i values)
- (values-names (gensym)))
- (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
- `(progn
- (define-hash-cache ,name ,args ,@options)
- (defun ,name ,arg-names
- ,@decls
- ,doc
- (cond #!+sb-show
- ((not (boundp '*hash-caches-initialized-p*))
- ;; This shouldn't happen, but it did happen to me
- ;; when revising the type system, and it's a lot
- ;; easier to figure out what what's going on with
- ;; that kind of problem if the system can be kept
- ;; alive until cold boot is complete. The recovery
- ;; mechanism should definitely be conditional on
- ;; some debugging feature (e.g. SB-SHOW) because
- ;; it's big, duplicating all the BODY code. -- WHN
- (/show0 ,name " too early in cold init, uncached")
- (/show0 ,(first arg-names) "=..")
- (/hexstr ,(first arg-names))
- ,@body)
- (t
- (multiple-value-bind ,(values-names)
- (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
- (if (and ,@(mapcar (lambda (val def)
- `(eq ,val ,def))
- (values-names) default-values))
- (multiple-value-bind ,(values-names)
- (progn ,@body)
- (,(symbolicate name "-CACHE-ENTER") ,@arg-names
- ,@(values-names))
- (values ,@(values-names)))
- (values ,@(values-names))))))))))))
+ (cdr default)
+ (list default)))
+ (arg-names (mapcar #'car args))
+ (values-names (make-gensym-list values)))
+ (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
+ `(progn
+ (define-hash-cache ,name ,args ,@options)
+ (defun ,name ,arg-names
+ ,@decls
+ ,doc
+ (cond #!+sb-show
+ ((not (boundp '*hash-caches-initialized-p*))
+ ;; This shouldn't happen, but it did happen to me
+ ;; when revising the type system, and it's a lot
+ ;; easier to figure out what what's going on with
+ ;; that kind of problem if the system can be kept
+ ;; alive until cold boot is complete. The recovery
+ ;; mechanism should definitely be conditional on some
+ ;; debugging feature (e.g. SB-SHOW) because it's big,
+ ;; duplicating all the BODY code. -- WHN
+ (/show0 ,name " too early in cold init, uncached")
+ (/show0 ,(first arg-names) "=..")
+ (/hexstr ,(first arg-names))
+ ,@body)
+ (t
+ (multiple-value-bind ,values-names
+ (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
+ (if (and ,@(mapcar (lambda (val def)
+ `(eq ,val ,def))
+ values-names default-values))
+ (multiple-value-bind ,values-names
+ (progn ,@body)
+ (,(symbolicate name "-CACHE-ENTER") ,@arg-names
+ ,@values-names)
+ (values ,@values-names))
+ (values ,@values-names))))))))))
(defmacro define-cached-synonym
(name &optional (original (symbolicate "%" name)))
- (let ((cached-name (symbolicate "%%" name "-cached")))
+ (let ((cached-name (symbolicate "%%" name "-CACHED")))
`(progn
(defun-cached (,cached-name :hash-bits 8
:hash-function (lambda (x)
(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)
+ (do () (())
+ (cond ((eql x y) (return t))
+ ((and (consp x)
+ (consp y)
+ (eql (pop x) (pop y))))
+ (t
+ (return)))))
\f
;;;; package idioms
(defun %find-package-or-lose (package-designator)
(or (find-package package-designator)
(error 'sb!kernel:simple-package-error
- :package package-designator
- :format-control "The name ~S does not designate any package."
- :format-arguments (list package-designator))))
+ :package package-designator
+ :format-control "The name ~S does not designate any package."
+ :format-arguments (list package-designator))))
;;; ANSI specifies (in the section for FIND-PACKAGE) that the
;;; consequences of most operations on deleted packages are
(defun find-undeleted-package-or-lose (package-designator)
(let ((maybe-result (%find-package-or-lose package-designator)))
(if (package-name maybe-result) ; if not deleted
- maybe-result
- (error 'sb!kernel:simple-package-error
- :package maybe-result
- :format-control "The package ~S has been deleted."
- :format-arguments (list maybe-result)))))
+ maybe-result
+ (error 'sb!kernel:simple-package-error
+ :package maybe-result
+ :format-control "The package ~S has been deleted."
+ :format-arguments (list maybe-result)))))
\f
;;;; various operations on names
;;; Is NAME a legal function name?
+(declaim (inline legal-fun-name-p))
(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)))))
+ (values (valid-function-name-p name)))
+
+(deftype function-name () '(satisfies legal-fun-name-p))
;;; 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))))
+ :datum name
+ :expected-type 'function-name
+ :format-control "invalid function name: ~S"
+ :format-arguments (list name))))
;;; Given a function name, return the symbol embedded in it.
;;;
(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))
- (t
- (error "not legal as a function name: ~S" fun-name))))
+ 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))))
(defun looks-like-name-of-special-var-p (x)
(and (symbolp x)
(let ((name (symbol-name x)))
- (and (> (length name) 2) ; to exclude '* and '**
- (char= #\* (aref name 0))
- (char= #\* (aref name (1- (length name))))))))
-
-;;; Some symbols are defined by ANSI to be self-evaluating. Return
-;;; non-NIL for such symbols (and make the non-NIL value a traditional
-;;; message, for use in contexts where the user asks us to change such
-;;; a symbol).
-(defun symbol-self-evaluating-p (symbol)
- (declare (type symbol symbol))
- (cond ((eq symbol t)
- "Veritas aeterna. (can't change T)")
- ((eq symbol nil)
- "Nihil ex nihil. (can't change NIL)")
- ((keywordp symbol)
- "Keyword values can't be changed.")
- (t
- nil)))
-
-;;; This function is to be called just before a change which would
-;;; affect the symbol value. (We don't absolutely have to call this
-;;; function before such changes, since such changes are given as
-;;; undefined behavior. In particular, we don't if the runtime cost
-;;; would be annoying. But otherwise it's nice to do so.)
-(defun about-to-modify-symbol-value (symbol)
- (declare (type symbol symbol))
- (let ((reason (symbol-self-evaluating-p symbol)))
- (when reason
- (error reason)))
- ;; (Note: Just because a value is CONSTANTP is not a good enough
- ;; reason to complain here, because we want DEFCONSTANT to be able
- ;; to use this function, and it's legal to DEFCONSTANT a constant as
- ;; long as the new value is EQL to the old value.)
- (values))
-
+ (and (> (length name) 2) ; to exclude '* and '**
+ (char= #\* (aref name 0))
+ (char= #\* (aref name (1- (length name))))))))
;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
;;; assignment instead of doing cold static linking. That way things like
;;; the linking eventually, so as long as #'FOO and #'BAR aren't
;;; needed until "cold toplevel forms" have executed, it's OK.
(defmacro cold-fset (name lambda)
- (style-warn
+ (style-warn
"~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
(SETF FDEFINITION)~:@>"
name)
;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA
- ;; expression so that the compiler can use NAME in debug names etc.
+ ;; expression so that the compiler can use NAME in debug names etc.
(destructuring-bind (lambda-symbol &rest lambda-rest) lambda
(assert (eql lambda-symbol 'lambda)) ; else dunno how to do conversion
`(setf (fdefinition ',name)
;;; bound to the corresponding temporary variable.
(defmacro once-only (specs &body body)
(named-let frob ((specs specs)
- (body body))
+ (body body))
(if (null specs)
- `(progn ,@body)
- (let ((spec (first specs)))
- ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
- (unless (proper-list-of-length-p spec 2)
- (error "malformed ONCE-ONLY binding spec: ~S" spec))
- (let* ((name (first spec))
- (exp-temp (gensym (symbol-name name))))
- `(let ((,exp-temp ,(second spec))
- (,name (gensym "ONCE-ONLY-")))
- `(let ((,,name ,,exp-temp))
- ,,(frob (rest specs) body))))))))
+ `(progn ,@body)
+ (let ((spec (first specs)))
+ ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
+ (unless (proper-list-of-length-p spec 2)
+ (error "malformed ONCE-ONLY binding spec: ~S" spec))
+ (let* ((name (first spec))
+ (exp-temp (gensym "ONCE-ONLY")))
+ `(let ((,exp-temp ,(second spec))
+ (,name (sb!xc:gensym ,(symbol-name name))))
+ `(let ((,,name ,,exp-temp))
+ ,,(frob (rest specs) body))))))))
\f
;;;; various error-checking utilities
;;; guts of complex systems anyway, I replaced it too.)
(defmacro aver (expr)
`(unless ,expr
- (%failed-aver ,(format nil "~A" expr))))
-
-(defun %failed-aver (expr-as-string)
- (bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
-
-;;; We need a definition of BUG here for the host compiler to be able
-;;; to deal with BUGs in sbcl. This should never affect an end-user,
-;;; who will pick up the definition that signals a CONDITION of
-;;; condition-class BUG; however, this is not defined on the host
-;;; lisp, but for the target. SBCL developers sometimes trigger BUGs
-;;; in their efforts, and it is useful to get the details of the BUG
-;;; rather than an undefined function error. - CSR, 2002-04-12
-#+sb-xc-host
+ (%failed-aver ',expr)))
+
+(defun %failed-aver (expr)
+ ;; hackish way to tell we're in a cold sbcl and output the
+ ;; message before signalling error, as it may be this is too
+ ;; early in the cold init.
+ (when (find-package "SB!C")
+ (fresh-line)
+ (write-line "failed AVER:")
+ (write expr)
+ (terpri))
+ (bug "~@<failed AVER: ~2I~_~A~:>" expr))
+
(defun bug (format-control &rest format-arguments)
- (error 'simple-error
- :format-control "~@< ~? ~:@_~?~:>"
- :format-arguments `(,format-control
- ,format-arguments
- "~@<If you see this and are an SBCL ~
-developer, then it is probable that you have made a change to the ~
-system that has broken the ability for SBCL to compile, usually by ~
-removing an assumed invariant of the system, but sometimes by making ~
-an averrance that is violated (check your code!). If you are a user, ~
-please submit a bug report to the developers' mailing list, details of ~
-which can be found at <http://sbcl.sourceforge.net/>.~:@>"
- ())))
+ (error 'bug
+ :format-control format-control
+ :format-arguments format-arguments))
(defmacro enforce-type (value type)
(once-only ((value value))
(%failed-enforce-type ,value ',type))))
(defun %failed-enforce-type (value type)
- (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-arguments (list value type)))
+ ;; maybe should be TYPE-BUG, subclass of BUG? If it is changed,
+ ;; check uses of it in user-facing code (e.g. WARN)
+ (error 'simple-type-error
+ :datum value
+ :expected-type type
+ :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))
;;; some commonly-occuring CONSTANTLY forms
(macrolet ((def-constantly-fun (name constant-expr)
- `(setf (symbol-function ',name)
- (constantly ,constant-expr))))
+ `(setf (symbol-function ',name)
+ (constantly ,constant-expr))))
(def-constantly-fun constantly-t t)
(def-constantly-fun constantly-nil nil)
(def-constantly-fun constantly-0 0))
-;;; If X is an atom, see whether it is present in *FEATURES*. Also
+;;; If X is a symbol, see whether it is present in *FEATURES*. Also
;;; handle arbitrary combinations of atoms using NOT, AND, OR.
(defun featurep (x)
- (if (consp x)
- (case (car x)
- ((:not not)
- (if (cddr x)
- (error "too many subexpressions in feature expression: ~S" x)
- (not (featurep (cadr x)))))
- ((:and and) (every #'featurep (cdr x)))
- ((:or or) (some #'featurep (cdr x)))
- (t
- (error "unknown operator in feature expression: ~S." x)))
- (not (null (memq x *features*)))))
-
-;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
-;;; &KEY-argument-list-style list of alternating keywords and
-;;; arbitrary values, return a new &KEY-argument-list-style list with
-;;; all substitutions applied to it.
-;;;
-;;; Note: If efficiency mattered, we could do less consing. (But if
-;;; efficiency mattered, why would we be using &KEY arguments at
-;;; all, much less renaming &KEY arguments?)
-;;;
-;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
-(defun rename-key-args (rename-list key-args)
- (declare (type list rename-list key-args))
- ;; Walk through RENAME-LIST modifying RESULT as per each element in
- ;; RENAME-LIST.
- (do ((result (copy-list key-args))) ; may be modified below
- ((null rename-list) result)
- (destructuring-bind (old new) (pop rename-list)
- ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
- (declare (type symbol old new))
- ;; Walk through RESULT renaming any OLD key argument to NEW.
- (do ((in-result result (cddr in-result)))
- ((null in-result))
- (declare (type list in-result))
- (when (eq (car in-result) old)
- (setf (car in-result) new))))))
-
-;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
-;;; other ANSI input functions, is defined to communicate end of file
-;;; status with its return value, not by signalling. That is not the
-;;; behavior that we usually want. This function is a wrapper which
-;;; restores the behavior that we usually want, causing READ-SEQUENCE
-;;; to communicate end-of-file status by signalling.
-(defun read-sequence-or-die (sequence stream &key start end)
- ;; implementation using READ-SEQUENCE
- #-no-ansi-read-sequence
- (let ((read-end (read-sequence sequence
- stream
- :start start
- :end end)))
- (unless (= read-end end)
- (error 'end-of-file :stream stream))
- (values))
- ;; workaround for broken READ-SEQUENCE
- #+no-ansi-read-sequence
- (progn
- (aver (<= start end))
- (let ((etype (stream-element-type stream)))
- (cond ((equal etype '(unsigned-byte 8))
- (do ((i start (1+ i)))
- ((>= i end)
- (values))
- (setf (aref sequence i)
- (read-byte stream))))
- (t (error "unsupported element type ~S" etype))))))
+ (typecase x
+ (cons
+ (case (car x)
+ ((:not not)
+ (cond
+ ((cddr x)
+ (error "too many subexpressions in feature expression: ~S" x))
+ ((null (cdr x))
+ (error "too few subexpressions in feature expression: ~S" x))
+ (t (not (featurep (cadr x))))))
+ ((:and and) (every #'featurep (cdr x)))
+ ((:or or) (some #'featurep (cdr x)))
+ (t
+ (error "unknown operator in feature expression: ~S." x))))
+ (symbol (not (null (memq x *features*))))
+ (t
+ (error "invalid feature expression: ~S" x))))
+
\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),
(let ((certain? t))
(dolist (i list (values nil certain?))
(multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
- (if sub-certain?
- (when sub-value (return (values t t)))
- (setf certain? nil))))))
+ (if sub-certain?
+ (when sub-value (return (values t t)))
+ (setf certain? nil))))))
(defun every/type (op thing list)
(declare (type function op))
(let ((certain? t))
(dolist (i list (if certain? (values t t) (values nil nil)))
(multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
- (if sub-certain?
- (unless sub-value (return (values nil t)))
- (setf certain? nil))))))
+ (if sub-certain?
+ (unless sub-value (return (values nil t)))
+ (setf certain? nil))))))
\f
;;;; DEFPRINTER
;;; These functions are called by the expansion of the DEFPRINTER
;;; macro to do the actual printing.
(declaim (ftype (function (symbol t stream) (values))
- defprinter-prin1 defprinter-princ))
+ defprinter-prin1 defprinter-princ))
(defun defprinter-prin1 (name value stream)
(defprinter-prinx #'prin1 name value stream))
(defun defprinter-princ (name value stream)
;;; The structure being printed is bound to STRUCTURE and the stream
;;; is bound to STREAM.
(defmacro defprinter ((name
- &key
- (conc-name (concatenate 'simple-string
- (symbol-name name)
- "-"))
- identity)
- &rest slot-descs)
+ &key
+ (conc-name (concatenate 'simple-string
+ (symbol-name name)
+ "-"))
+ identity)
+ &rest slot-descs)
(let ((first? t)
- maybe-print-space
- (reversed-prints nil)
- (stream (gensym "STREAM")))
+ maybe-print-space
+ (reversed-prints nil)
+ (stream (sb!xc:gensym "STREAM")))
(flet ((sref (slot-name)
- `(,(symbolicate conc-name slot-name) structure)))
+ `(,(symbolicate conc-name slot-name) structure)))
(dolist (slot-desc slot-descs)
- (if first?
- (setf maybe-print-space nil
- first? nil)
- (setf maybe-print-space `(defprinter-print-space ,stream)))
- (cond ((atom slot-desc)
- (push maybe-print-space reversed-prints)
- (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
- reversed-prints))
- (t
- (let ((sname (first slot-desc))
- (test t))
- (collect ((stuff))
- (do ((option (rest slot-desc) (cddr option)))
- ((null option)
- (push `(let ((,sname ,(sref sname)))
- (when ,test
- ,maybe-print-space
- ,@(or (stuff)
- `((defprinter-prin1
- ',sname ,sname ,stream)))))
- reversed-prints))
- (case (first option)
- (:prin1
- (stuff `(defprinter-prin1
- ',sname ,(second option) ,stream)))
- (:princ
- (stuff `(defprinter-princ
- ',sname ,(second option) ,stream)))
- (:test (setq test (second option)))
- (t
- (error "bad option: ~S" (first option)))))))))))
+ (if first?
+ (setf maybe-print-space nil
+ first? nil)
+ (setf maybe-print-space `(defprinter-print-space ,stream)))
+ (cond ((atom slot-desc)
+ (push maybe-print-space reversed-prints)
+ (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
+ reversed-prints))
+ (t
+ (let ((sname (first slot-desc))
+ (test t))
+ (collect ((stuff))
+ (do ((option (rest slot-desc) (cddr option)))
+ ((null option)
+ (push `(let ((,sname ,(sref sname)))
+ (when ,test
+ ,maybe-print-space
+ ,@(or (stuff)
+ `((defprinter-prin1
+ ',sname ,sname ,stream)))))
+ reversed-prints))
+ (case (first option)
+ (:prin1
+ (stuff `(defprinter-prin1
+ ',sname ,(second option) ,stream)))
+ (:princ
+ (stuff `(defprinter-princ
+ ',sname ,(second option) ,stream)))
+ (:test (setq test (second option)))
+ (t
+ (error "bad option: ~S" (first option)))))))))))
`(def!method print-object ((structure ,name) ,stream)
(pprint-logical-block (,stream nil)
- (print-unreadable-object (structure
- ,stream
- :type t
- :identity ,identity)
- ,@(nreverse reversed-prints))))))
+ (print-unreadable-object (structure
+ ,stream
+ :type t
+ :identity ,identity)
+ ,@(nreverse reversed-prints))))))
\f
;;;; etc.
(translate-logical-pathname possibly-logical-pathname)
possibly-logical-pathname))
-(defun deprecation-warning (bad-name &optional good-name)
- (warn "using deprecated ~S~@[, should use ~S instead~]"
- bad-name
- good-name))
+;;;; Deprecating stuff
+
+(defun normalize-deprecation-replacements (replacements)
+ (if (or (not (listp replacements))
+ (eq 'setf (car replacements)))
+ (list replacements)
+ replacements))
+
+(defun deprecation-error (since name replacements)
+ (error 'deprecation-error
+ :name name
+ :replacements (normalize-deprecation-replacements replacements)
+ :since since))
+
+(defun deprecation-warning (state since name replacements
+ &key (runtime-error (neq :early state)))
+ (warn (ecase state
+ (:early 'early-deprecation-warning)
+ (:late 'late-deprecation-warning)
+ (:final 'final-deprecation-warning))
+ :name name
+ :replacements (normalize-deprecation-replacements replacements)
+ :since since
+ :runtime-error runtime-error))
+
+(defun deprecated-function (since name replacements)
+ (lambda (&rest deprecated-function-args)
+ (declare (ignore deprecated-function-args))
+ (deprecation-error since name replacements)))
+
+(defun deprecation-compiler-macro (state since name replacements)
+ (lambda (form env)
+ (declare (ignore env))
+ (deprecation-warning state since name replacements)
+ form))
+
+;;; STATE is one of
+;;;
+;;; :EARLY, for a compile-time style-warning.
+;;; :LATE, for a compile-time full warning.
+;;; :FINAL, for a compile-time full warning and runtime error.
+;;;
+;;; Suggested duration of each stage is one year, but some things can move faster,
+;;; and some widely used legacy APIs might need to move slower. Internals we don't
+;;; usually add deprecation notes for, but sometimes an internal API actually has
+;;; several external users, in which case we try to be nice about it.
+;;;
+;;; When you deprecate something, note it here till it is fully gone: makes it
+;;; easier to keep things progressing orderly. Also add the relevant section
+;;; (or update it when deprecation proceeds) in the manual, in
+;;; deprecated.texinfo.
+;;;
+;;; EARLY:
+;;; - SB-THREAD::GET-MUTEX, since 1.0.37.33 (04/2010) -> Late: 01/2013
+;;; ^- initially deprecated without compile-time warning, hence the schedule
+;;; - SB-THREAD::SPINLOCK (type), since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::MAKE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::WITH-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::WITH-RECURSIVE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::GET-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::RELEASE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::SPINLOCK-VALUE, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SETF SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-C::MERGE-TAIL-CALLS (policy), since 1.0.53.74 (11/2011) -> Late: 11/2012
+;;; - SB-EXT:QUIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
+;;; - SB-UNIX:UNIX-EXIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
+;;; - SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS*, since 1.1.4.9 (02/2013) -> Late: 02/2014
+;;;
+;;; LATE:
+;;; - SB-SYS:OUTPUT-RAW-BYTES, since 1.0.8.16 (06/2007) -> Final: anytime
+;;; Note: make sure CLX doesn't use it anymore!
+;;; - SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-C::STACK-ALLOCATE-VECTOR (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-C::STACK-ALLOCATE-VALUE-CELLS (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-INTROSPECT:FUNCTION-ARGLIST, since 1.0.24.5 (01/2009) -> Final: anytime
+;;; - SB-THREAD:JOIN-THREAD-ERROR-THREAD, since 1.0.29.17 (06/2009) -> Final: 09/2012
+;;; - SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD since 1.0.29.17 (06/2009) -> Final: 06/2012
+
+(defmacro define-deprecated-function (state since name replacements lambda-list &body body)
+ (let* ((replacements (normalize-deprecation-replacements replacements))
+ (doc
+ (let ((*package* (find-package :keyword))
+ (*print-pretty* nil))
+ (apply #'format nil
+ "~S has been deprecated as of SBCL ~A.~
+ ~#[~;~2%Use ~S instead.~;~2%~
+ Use ~S or ~S instead.~:;~2%~
+ Use~@{~#[~; or~] ~S~^,~} instead.~]"
+ name since replacements))))
+ `(progn
+ ,(ecase state
+ ((:early :late)
+ `(progn
+ (defun ,name ,lambda-list
+ ,doc
+ ,@body)))
+ ((:final)
+ `(progn
+ (declaim (ftype (function * nil) ,name))
+ (setf (fdefinition ',name)
+ (deprecated-function ',name ',replacements ,since))
+ (setf (documentation ',name 'function) ,doc))))
+ (setf (compiler-macro-function ',name)
+ (deprecation-compiler-macro ,state ,since ',name ',replacements)))))
+
+(defun check-deprecated-variable (name)
+ (let ((info (info :variable :deprecated name)))
+ (when info
+ (deprecation-warning (car info) (cdr info) name nil))))
+
+(defmacro define-deprecated-variable (state since name &key (value nil valuep) replacement)
+ `(progn
+ (setf (info :variable :deprecated ',name) (cons ,state ,since))
+ ,@(when (member state '(:early :late))
+ `((defvar ,name ,@(when valuep (list value))
+ ,(let ((*package* (find-package :keyword)))
+ (format nil
+ "~@<~S has been deprecated as of SBCL ~A~@[, use ~S instead~].~:>"
+ name since replacement)))))))
;;; Anaphoric macros
(defmacro awhen (test &body body)
`(if ,test
(let ((it ,test)) (declare (ignorable it)),@body)
(acond ,@rest))))))
+
+;;; (binding* ({(names 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
+ (collect ((new-names) (ignorable))
+ (dolist (name names)
+ (when (eq name nil)
+ (setq name (gensym))
+ (ignorable name))
+ (new-names name))
+ (values (new-names)
+ (when (ignorable)
+ `((declare (ignorable ,@(ignorable)))))))))
+ (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)))
+
+;;; Bind a few "potentially dangerous" printer control variables to
+;;; safe values, respecting current values if possible.
+(defmacro with-sane-io-syntax (&body forms)
+ `(call-with-sane-io-syntax (lambda () ,@forms)))
+
+(defun call-with-sane-io-syntax (function)
+ (declare (type function function))
+ (macrolet ((true (sym)
+ `(and (boundp ',sym) ,sym)))
+ (let ((*print-readably* nil)
+ (*print-level* (or (true *print-level*) 6))
+ (*print-length* (or (true *print-length*) 12)))
+ (funcall function))))
+
+;;; Returns a list of members of LIST. Useful for dealing with circular lists.
+;;; For a dotted list returns a secondary value of T -- in which case the
+;;; primary return value does not include the dotted tail.
+;;; If the maximum length is reached, return a secondary value of :MAYBE.
+(defun list-members (list &key max-length)
+ (when list
+ (do ((tail (cdr list) (cdr tail))
+ (members (list (car list)) (cons (car tail) members))
+ (count 0 (1+ count)))
+ ((or (not (consp tail)) (eq tail list)
+ (and max-length (>= count max-length)))
+ (values members (or (not (listp tail))
+ (and (>= count max-length) :maybe)))))))
+
+;;; Default evaluator mode (interpeter / compiler)
+
+(declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*))
+(defparameter *evaluator-mode* :compile
+ #!+sb-doc
+ "Toggle between different evaluator implementations. If set to :COMPILE,
+an implementation of EVAL that calls the compiler will be used. If set
+to :INTERPRET, an interpreter will be used.")
+
+;;; Helper for making the DX closure allocation in macros expanding
+;;; to CALL-WITH-FOO less ugly.
+(defmacro dx-flet (functions &body forms)
+ `(flet ,functions
+ (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
+ ,@(mapcar (lambda (func) `(function ,(car func))) functions)))
+ ,@forms))
+
+;;; Another similar one.
+(defmacro dx-let (bindings &body forms)
+ `(let ,bindings
+ (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
+ ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind))
+ bindings)))
+ ,@forms))
+
+(in-package "SB!KERNEL")
+
+(defun fp-zero-p (x)
+ (typecase x
+ (single-float (zerop x))
+ (double-float (zerop x))
+ #!+long-float
+ (long-float (zerop x))
+ (t nil)))
+
+(defun neg-fp-zero (x)
+ (etypecase x
+ (single-float
+ (if (eql x 0.0f0)
+ (make-unportable-float :single-float-negative-zero)
+ 0.0f0))
+ (double-float
+ (if (eql x 0.0d0)
+ (make-unportable-float :double-float-negative-zero)
+ 0.0d0))
+ #!+long-float
+ (long-float
+ (if (eql x 0.0l0)
+ (make-unportable-float :long-float-negative-zero)
+ 0.0l0))))
+
+;;; Signalling an error when trying to print an error condition is
+;;; generally a PITA, so whatever the failure encountered when
+;;; wondering about FILE-POSITION within a condition printer, 'tis
+;;; better silently to give up than to try to complain.
+(defun file-position-or-nil-for-error (stream &optional (pos nil posp))
+ ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but
+ ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem
+ ;; absolutely unambiguously to prohibit errors when, e.g., STREAM
+ ;; has been closed so that FILE-POSITION is a nonsense question. So
+ ;; my (WHN) impression is that the conservative approach is to
+ ;; IGNORE-ERRORS. (I encountered this failure from within a homebrew
+ ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd,
+ ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the
+ ;; time an error was reported.)
+ (if posp
+ (ignore-errors (file-position stream pos))
+ (ignore-errors (file-position stream))))
+
+(defun stream-error-position-info (stream &optional position)
+ (unless (interactive-stream-p stream)
+ (let ((now (file-position-or-nil-for-error stream))
+ (pos position))
+ (when (and (not pos) now (plusp now))
+ ;; FILE-POSITION is the next character -- error is at the previous one.
+ (setf pos (1- now)))
+ (let (lineno colno)
+ (when (and pos
+ (< pos sb!xc:array-dimension-limit)
+ (file-position stream :start))
+ (let ((string
+ (make-string pos :element-type (stream-element-type stream))))
+ (when (= pos (read-sequence string stream))
+ ;; Lines count from 1, columns from 0. It's stupid and traditional.
+ (setq lineno (1+ (count #\Newline string))
+ colno (- pos (or (position #\Newline string :from-end t) 0)))))
+ (file-position-or-nil-for-error stream now))
+ (remove-if-not #'second
+ (list (list :line lineno)
+ (list :column colno)
+ (list :file-position pos)))))))
+
+(declaim (inline schwartzian-stable-sort-list))
+(defun schwartzian-stable-sort-list (list comparator &key key)
+ (if (null key)
+ (stable-sort (copy-list list) comparator)
+ (let* ((key (if (functionp key)
+ key
+ (symbol-function key)))
+ (wrapped (mapcar (lambda (x)
+ (cons x (funcall key x)))
+ list))
+ (sorted (stable-sort wrapped comparator :key #'cdr)))
+ (map-into sorted #'car sorted))))
projects / sbcl.git / blobdiff