X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=b73ac29033f7c44aa273907cbd28a163c7728f1e;hb=83ff95b8a70b1dc7cfffdf0a6bb7f4500ebe1ca1;hp=481a83dfcda537095ebdfe83b98ac981f5cc6f81;hpb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 481a83d..b73ac29 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -13,23 +13,46 @@ (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 @@ -49,21 +72,67 @@ ;;; 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 @@ -105,25 +174,53 @@ ;;;; type-ish predicates -;;; 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 @@ -133,20 +230,20 @@ (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 *)))) ;;;; the COLLECT macro @@ -169,15 +266,15 @@ (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 @@ -200,30 +297,30 @@ ;;; 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)))) ;;;; some old-fashioned functions. (They're not just for old-fashioned @@ -261,7 +358,12 @@ ;; 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): @@ -270,13 +372,13 @@ (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): @@ -294,50 +396,91 @@ ;;; 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)))) ;;;; 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))))) + ;;;; hash cache utility @@ -359,6 +502,17 @@ ;;; 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: ;;; -CACHE-LOOKUP Arg* ;;; See whether there is an entry for the specified ARGs in the @@ -383,35 +537,47 @@ ;;; 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) @@ -419,128 +585,113 @@ (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) @@ -564,13 +715,13 @@ ;;; 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))) + (do () (()) + (cond ((eql x y) (return t)) + ((and (consp x) + (consp y) + (eql (pop x) (pop y)))) + (t + (return))))) ;;;; package idioms @@ -581,9 +732,9 @@ (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 @@ -591,26 +742,29 @@ (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))))) ;;;; various operations on names ;;; Is NAME a legal function name? +(declaim (inline legal-fun-name-p)) (defun legal-fun-name-p (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. ;;; @@ -623,54 +777,22 @@ (declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) (defun fun-name-block-name (fun-name) (cond ((symbolp 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)))) + 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 @@ -682,12 +804,12 @@ ;;; 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 "~@" 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) @@ -711,19 +833,19 @@ ;;; 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)))))))) ;;;; various error-checking utilities @@ -752,32 +874,23 @@ ;;; 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 "~@" 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 "~@" expr)) + (defun bug (format-control &rest format-arguments) - (error 'simple-error - :format-control "~@< ~? ~:@_~?~:>" - :format-arguments `(,format-control - ,format-arguments - "~@.~:@>" - ()))) + (error 'bug + :format-control format-control + :format-arguments format-arguments)) (defmacro enforce-type (value type) (once-only ((value value)) @@ -785,11 +898,13 @@ which can be found at .~:@>" (%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))) ;;; Return a function like FUN, but expecting its (two) arguments in ;;; the opposite order that FUN does. @@ -814,84 +929,45 @@ which can be found at .~:@>" ;;; 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)))) + ;;;; 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) @@ -912,24 +988,24 @@ which can be found at .~:@>" (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)))))) ;;;; 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) @@ -968,57 +1044,57 @@ which can be found at .~:@>" ;;; 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)))))) ;;;; etc. @@ -1028,10 +1104,126 @@ which can be found at .~:@>" (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) @@ -1046,3 +1238,214 @@ which can be found at .~:@>" `(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)))) + +;;; 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))) + +;;; 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))))