X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=c9cdbf718426bc96f779668ac0dd626d02506354;hb=279283bc1724b60ef9ebbf31ab4837061989be18;hp=4522aa2fb463bc8746aec2c5a6667f61762a6705;hpb=b0642df835dc2fca3e4cf47aff978ecdc88799d5;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 4522aa2..c9cdbf7 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -30,6 +30,10 @@ ;;; bound because ANSI specifies it as an exclusive bound.) (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 +53,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))) + +#!+x86 +(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))) + +#!+x86 +(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) 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 +155,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))))) -;;; Is X is a positive prime integer? +(declaim (inline singleton-p)) +(defun singleton-p (list) + (and (consp list) + (null (rest list)))) + +;;; Is X is a positive prime integer? (defun positive-primep (x) ;; This happens to be called only from one place in sbcl-0.7.0, and ;; only for fixnums, we can limit it to fixnums for efficiency. (And @@ -133,20 +211,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 @@ -161,7 +239,7 @@ ;;; 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) @@ -169,15 +247,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 +278,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 +339,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 +353,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): @@ -300,10 +383,19 @@ (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" +;;; "the ultimate iteration macro" ;;; ;;; note for Schemers: This seems to be identical to Scheme's "named LET". (defmacro named-let (name binds &body body) @@ -314,30 +406,44 @@ `(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))))) +(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. (defmacro dohash ((key-var value-var table &optional result) &body body) - (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (let ((gen (gensym)) - (n-more (gensym))) + (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)))))) + (loop + (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) + ,@decls + (unless ,n-more (return ,result)) + ,@forms)))))) ;;;; hash cache utility @@ -359,6 +465,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 @@ -384,34 +501,36 @@ ;;; 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)) + (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))) + (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 (gensym)) + (args-and-values-size (+ nargs values)) + (n-index (gensym)) + (n-cache (gensym))) (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 (gensym))) + (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 +538,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))))) + (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))))) (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 ,(symbolicate "*" name "-CACHE-PROBES*")))) + (let* ((,n-index (,hash-function ,@(arg-vars))) + (,n-cache ,var-name) + (,args-and-values (svref ,n-cache ,n-index))) + (cond ((and ,args-and-values + ,@(tests)) + (values ,@(values-refs))) + (t + ,@(when *profile-hash-cache* + `((incf ,(symbolicate "*" name "-CACHE-MISSES*")))) + ,default)))))) (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 ,var-name) + (,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))) + (forms + `(defun ,fun-name () + (fill ,var-name nil))) + (forms `(,fun-name))) (inits `(unless (boundp ',var-name) - (setq ,var-name (make-array ,total-size)))) + (setq ,var-name (make-array ,size :initial-element 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)))) + (defvar ,var-name) + (declaim (type (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))) + (cdr default) + (list default))) + (arg-names (mapcar #'car args))) (collect ((values-names)) (dotimes (i values) - (values-names (gensym))) + (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)))))))))))) + `(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) @@ -568,8 +672,8 @@ ((eql x y) t) ((consp x) (and (consp y) - (eql (car x) (car y)) - (equal-but-no-car-recursion (cdr x) (cdr y)))) + (eql (car x) (car y)) + (equal-but-no-car-recursion (cdr x) (cdr y)))) (t nil))) ;;;; package idioms @@ -581,9 +685,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,45 +695,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) - (or (symbolp name) - (and (consp name) - ;; (SETF FOO) - ;; (CLASS-PREDICATE FOO) - (or (and (or (eq (car name) 'setf) - (eq (car name) 'sb!pcl::class-predicate)) - (consp (cdr name)) - (symbolp (cadr name)) - (null (cddr name))) - ;; (SLOT-ACCESSOR - ;; [READER|WRITER|BOUNDP]) - (and (eq (car name) 'sb!pcl::slot-accessor) - (consp (cdr name)) - (symbolp (cadr name)) - (consp (cddr name)) - (symbolp (caddr name)) - (consp (cdddr name)) - (member - (cadddr name) - '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp))))))) + (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. ;;; @@ -642,21 +730,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) - ((and (consp fun-name) - (legal-fun-name-p fun-name)) - (case (car fun-name) - ((setf sb!pcl::class-predicate) (second fun-name)) - ((sb!pcl::slot-accessor) (third 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)))))))) + (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 @@ -665,13 +754,13 @@ (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))) + "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 @@ -700,12 +789,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) @@ -729,19 +818,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 (symbol-name name)))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym "ONCE-ONLY-"))) + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) ;;;; various error-checking utilities @@ -773,29 +862,20 @@ (%failed-aver ,(format nil "~A" expr)))) (defun %failed-aver (expr-as-string) + ;; hackish way to tell we're in a cold sbcl and output the + ;; message before signallign 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-line expr-as-string) + (terpri)) (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 (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)) @@ -803,18 +883,14 @@ 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 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)) @@ -838,8 +914,8 @@ 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)) @@ -851,8 +927,8 @@ which can be found at .~:@>" (case (car x) ((:not not) (if (cddr x) - (error "too many subexpressions in feature expression: ~S" x) - (not (featurep (cadr 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 @@ -880,10 +956,10 @@ which can be found at .~:@>" (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)))))) + ((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 @@ -895,9 +971,9 @@ which can be found at .~:@>" ;; implementation using READ-SEQUENCE #-no-ansi-read-sequence (let ((read-end (read-sequence sequence - stream - :start start - :end end))) + stream + :start start + :end end))) (unless (= read-end end) (error 'end-of-file :stream stream)) (values)) @@ -907,15 +983,33 @@ which can be found at .~:@>" (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)))))) + (do ((i start (1+ i))) + ((>= i end) + (values)) + (setf (aref sequence i) + (read-byte stream)))) + (t (error "unsupported element type ~S" etype)))))) ;;;; 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), @@ -927,24 +1021,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) @@ -983,57 +1077,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 (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. @@ -1045,8 +1139,8 @@ which can be found at .~:@>" (defun deprecation-warning (bad-name &optional good-name) (warn "using deprecated ~S~@[, should use ~S instead~]" - bad-name - good-name)) + bad-name + good-name)) ;;; Anaphoric macros (defmacro awhen (test &body body) @@ -1061,3 +1155,105 @@ 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)))) + +;;; 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.") +