X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=71f590b5ce79e0e4b5daac0e9fcf10923aeb03d5;hb=2963d6858d147b23c33f38e051e61264b479c9fc;hp=9642a5f3782697be7441bbab54795f218edc423b;hpb=6f408b4ce6a2f411618fe1bebf63ee08093a7d03;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 9642a5f..71f590b 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1,11 +1,6 @@ -;;;; This file contains definitions and declarations for the -;;;; EXTENSIONS package which must be available at early cross-compile -;;;; time, and perhaps also some things which might as well be built -;;;; at cross-compile time even if they're not strictly needed, since -;;;; that's harmless. Things which can't be built at cross-compile -;;;; time (e.g. because they need machinery which only exists inside -;;;; CMU CL's implementation of the LISP package) do not belong in -;;;; this file. +;;;; various extensions (including SB-INT "internal extensions") +;;;; available both in the cross-compilation host Lisp and in the +;;;; target SBCL ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -16,10 +11,22 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!EXT") +(in-package "SB!IMPL") -(file-comment - "$Header$") +;;; Lots of code wants to get to the KEYWORD package or the +;;; COMMON-LISP package without a lot of fuss, so we cache them in +;;; variables. TO DO: How much does this actually buy us? It sounds +;;; sensible, but I don't know for sure that it saves space or time.. +;;; -- WHN 19990521 +;;; +;;; (The initialization forms here only matter on the cross-compilation +;;; host; In the target SBCL, these variables are set in cold init.) +(declaim (type package *cl-package* *keyword-package*)) +(defvar *cl-package* (find-package "COMMON-LISP")) +(defvar *keyword-package* (find-package "KEYWORD")) + +;;; 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 @@ -35,10 +42,30 @@ ;;; bound because ANSI specifies it as an exclusive bound.) (def!type index () `(integer 0 (,sb!xc:array-dimension-limit))) +;;; 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 +;;; index leaving the loop range) +(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit))) + ;;; the default value used for initializing character data. The ANSI -;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid -;;; because it's not in the ANSI table of portable characters. -(defconstant default-init-char #\space) +;;; spec says this is arbitrary, so we use the value that falls +;;; through when we just let the low-level consing code initialize +;;; all newly-allocated memory to zero. +;;; +;;; KLUDGE: It might be nice to use something which is a +;;; STANDARD-CHAR, both to reduce user surprise a little and, probably +;;; more significantly, to help SBCL's cross-compiler (which knows how +;;; to dump STANDARD-CHARs). Unfortunately, the old CMU CL code is +;;; shot through with implicit assumptions that it's #\NULL, and code +;;; in several places (notably both DEFUN MAKE-ARRAY and DEFTRANSFORM +;;; MAKE-ARRAY) would have to be rewritten. -- WHN 2001-10-04 +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; an expression we can use to construct a DEFAULT-INIT-CHAR value + ;; at load time (so that we don't need to teach the cross-compiler + ;; how to represent and dump non-STANDARD-CHARs like #\NULL) + (defparameter *default-init-char-form* '(code-char 0))) +(defconstant default-init-char #.*default-init-char-form*) ;;; CHAR-CODE values for ASCII characters which we care about but ;;; which aren't defined in section "2.1.3 Standard Characters" of the @@ -52,31 +79,250 @@ ;;; (or just find a nicer way of expressing characters portably?) -- ;;; WHN 19990713 (defconstant bell-char-code 7) +(defconstant backspace-char-code 8) (defconstant tab-char-code 9) +(defconstant line-feed-char-code 10) (defconstant form-feed-char-code 12) (defconstant return-char-code 13) (defconstant escape-char-code 27) (defconstant rubout-char-code 127) -;;; Concatenate together the names of some strings and symbols, -;;; producing a symbol in the current package. +;;;; type-ish predicates + +;;; a helper function for various macros which expect clauses of a +;;; given length, etc. +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Return true if X is a proper list whose length is between MIN and + ;; MAX (inclusive). + (defun proper-list-of-length-p (x min &optional (max min)) + ;; FIXME: This implementation will hang on circular list + ;; structure. Since this is an error-checking utility, i.e. its + ;; job is to deal with screwed-up input, it'd be good style to fix + ;; it so that it can deal with circular list structure. + (cond ((minusp max) + nil) + ((null x) + (zerop min)) + ((consp x) + (and (plusp max) + (proper-list-of-length-p (cdr x) + (if (plusp (1- min)) + (1- min) + 0) + (1- max)))) + (t nil)))) + +;;; Is X a list containing a cycle? +(defun cyclic-list-p (x) + (and (listp x) + (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)))))) + +;;; 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))))) + +;;; Is X is a positive prime integer? +(defun positive-primep (x) + ;; This happens to be called only from one place in sbcl-0.7.0, and + ;; only for fixnums, we can limit it to fixnums for efficiency. (And + ;; if we didn't limit it to fixnums, we should use a cleverer + ;; algorithm, since this one scales pretty badly for huge X.) + (declare (fixnum x)) + (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)))))) + +;;; 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) + (typep x '(array t *)))) + +;;;; the COLLECT macro +;;;; +;;;; comment from CMU CL: "the ultimate collection macro..." + +;;; helper functions for COLLECT, which become the expanders of the +;;; MACROLET definitions created by COLLECT +;;; +;;; COLLECT-NORMAL-EXPANDER handles normal collection macros. +;;; +;;; 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) - (declaim (ftype (function (&rest (or string symbol)) symbol) symbolicate)) - (defun symbolicate (&rest things) - (values (intern (apply #'concatenate - 'string - (mapcar #'string things)))))) - -;;; like SYMBOLICATE, but producing keywords -(defun keywordicate (&rest things) - (let ((*package* *keyword-package*)) - (apply #'symbolicate things))) + (defun collect-normal-expander (n-value fun forms) + `(progn + ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) + ,n-value)) + (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)))) + +;;; Collect some values somehow. Each of the collections specifies a +;;; bunch of things which collected during the evaluation of the body +;;; of the form. The name of the collection is used to define a local +;;; macro, a la MACROLET. Within the body, this macro will evaluate +;;; each of its arguments and collect the result, returning the +;;; current value after the collection is done. The body is evaluated +;;; as a PROGN; to get the final values when you are done, just call +;;; the collection macro with no arguments. +;;; +;;; INITIAL-VALUE is the value that the collection starts out with, +;;; which defaults to NIL. FUNCTION is the function which does the +;;; collection. It is a function which will accept two arguments: the +;;; value to be collected and the current collection. The result of +;;; the function is made the new value for the collection. As a +;;; totally magical special-case, FUNCTION may be COLLECT, which tells +;;; us to build a list in forward order; this is the default. If an +;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd +;;; onto the end. Note that FUNCTION may be anything that can appear +;;; in the functional position, including macros and lambdas. +(defmacro collect (collections &body body) + (let ((macros ()) + (binds ())) + (dolist (spec collections) + (unless (proper-list-of-length-p spec 1 3) + (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)))) + `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) + +;;;; some old-fashioned functions. (They're not just for old-fashioned +;;;; code, they're also used as optimized forms of the corresponding +;;;; general functions when the compiler can prove that they're +;;;; equivalent.) + +;;; like (MEMBER ITEM LIST :TEST #'EQ) +(defun memq (item list) + #!+sb-doc + "Return tail of LIST beginning with first element EQ to ITEM." + ;; KLUDGE: These could be and probably should be defined as + ;; (MEMBER ITEM LIST :TEST #'EQ)), + ;; but when I try to cross-compile that, I get an error from + ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The + ;; comments for that error say it "is probably a botched interpreter stub". + ;; Rather than try to figure that out, I just rewrote this function from + ;; scratch. -- WHN 19990512 + (do ((i list (cdr i))) + ((null i)) + (when (eq (car i) item) + (return i)))) + +;;; like (ASSOC ITEM ALIST :TEST #'EQ): +;;; Return the first pair of ALIST where ITEM is EQ to the key of +;;; the pair. +(defun assq (item alist) + ;; KLUDGE: CMU CL defined this with + ;; (DECLARE (INLINE ASSOC)) + ;; (ASSOC ITEM ALIST :TEST #'EQ)) + ;; which is pretty, but which would have required adding awkward + ;; build order constraints on SBCL (or figuring out some way to make + ;; inline definitions installable at build-the-cross-compiler time, + ;; which was too ambitious for now). Rather than mess with that, we + ;; just define ASSQ explicitly in terms of more primitive + ;; operations: + (dolist (pair alist) + (when (eq (car pair) item) + (return pair)))) + +;;; like (DELETE .. :TEST #'EQ): +;;; Delete all LIST entries EQ to ITEM (destructively modifying +;;; LIST), and return the modified LIST. +(defun delq (item list) + (let ((list list)) + (do ((x list (cdr x)) + (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. + + +;;; like (POSITION .. :TEST #'EQ): +;;; Return the position of the first element EQ to ITEM. +(defun posq (item list) + (do ((i list (cdr i)) + (j 0 (1+ j))) + ((null i)) + (when (eq (car i) item) + (return j)))) + +(declaim (inline neq)) +(defun neq (x y) + (not (eq x y))) + +;;; 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 +(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)) ;;;; miscellaneous iteration extensions -(defmacro dovector ((elt vector &optional result) &rest forms) +;;; "the ultimate iteration macro" +;;; +;;; note for Schemers: This seems to be identical to Scheme's "named LET". +(defmacro named-let (name binds &body body) #!+sb-doc - "just like DOLIST, but with one-dimensional arrays" + (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)))) + +;;; just like DOLIST, but with one-dimensional arrays +(defmacro dovector ((elt vector &optional result) &rest forms) (let ((index (gensym)) (length (gensym)) (vec (gensym))) @@ -88,10 +334,8 @@ (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) - #!+sb-doc - "DOHASH (Key-Var Value-Var Table [Result]) Declaration* Form* - Iterate over the entries in a hash-table." (multiple-value-bind (forms decls) (parse-body body nil) (let ((gen (gensym)) (n-more (gensym))) @@ -107,49 +351,48 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *profile-hash-cache* nil)) -;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions -;;; so that caches will be created before top-level forms run. +;;; a flag for whether it's too early in cold init to use caches so +;;; that we have a better chance of recovering so that we have a +;;; better chance of getting the system running so that we have a +;;; better chance of diagnosing the problem which caused us to use the +;;; caches too early +#!+sb-show +(defvar *hash-caches-initialized-p*) + +;;; Define a hash cache that associates some number of argument values +;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME +;;; is used to compare the value for that arg in a cache entry with a +;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as +;;; its first arg, but need not return any particular value. +;;; TEST-FUNCTION may be any thing that can be placed in CAR position. +;;; +;;; NAME is used to define these functions: +;;; -CACHE-LOOKUP Arg* +;;; See whether there is an entry for the specified ARGs in the +;;; cache. If not present, the :DEFAULT keyword (default NIL) +;;; determines the result(s). +;;; -CACHE-ENTER Arg* Value* +;;; Encache the association of the specified args with VALUE. +;;; -CACHE-CLEAR +;;; Reinitialize the cache, invalidating all entries and allowing +;;; the arguments and result values to be GC'd. +;;; +;;; These other keywords are defined: +;;; :HASH-BITS +;;; The size of the cache as a power of 2. +;;; :HASH-FUNCTION function +;;; Some thing that can be placed in CAR position which will compute +;;; a value between 0 and (1- (expt 2 )). +;;; :VALUES +;;; the number of return values cached for each function call +;;; :INIT-WRAPPER +;;; The code for initializing the cache is wrapped in a form with +;;; 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)) - #!+sb-doc - "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}* - Define a hash cache that associates some number of argument values to a - result value. The Test-Function paired with each Arg-Name is used to compare - the value for that arg in a cache entry with a supplied arg. The - Test-Function must not error when passed NIL as its first arg, but need not - return any particular value. Test-Function may be any thing that can be - placed in CAR position. - - Name is used to define these functions: - - -CACHE-LOOKUP Arg* - See whether there is an entry for the specified Args in the cache. If - not present, the :DEFAULT keyword (default NIL) determines the result(s). - - -CACHE-ENTER Arg* Value* - Encache the association of the specified args with Value. - - -CACHE-CLEAR - Reinitialize the cache, invalidating all entries and allowing the - arguments and result values to be GC'd. - - These other keywords are defined: - - :HASH-BITS - The size of the cache as a power of 2. - - :HASH-FUNCTION function - Some thing that can be placed in CAR position which will compute a value - between 0 and (1- (expt 2 )). - - :VALUES - The number of values cached. - - :INIT-WRAPPER - The code for initializing the cache is wrapped in a form with the - specified name. Default PROGN." - (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) (nargs (length args)) (entry-size (+ nargs values)) @@ -162,7 +405,7 @@ (n-cache (gensym))) (unless (= (length default-values) values) - (error "The number of default values ~S differs from :VALUES ~D." + (error "The number of default values ~S differs from :VALUES ~W." default values)) (collect ((inlines) @@ -179,7 +422,7 @@ (let ((n 0)) (dolist (arg args) (unless (= (length arg) 2) - (error "bad arg spec: ~S" arg)) + (error "bad argument spec: ~S" arg)) (let ((arg-name (first arg)) (test (second arg))) (arg-vars arg-name) @@ -221,8 +464,8 @@ (,n-cache ,var-name)) (declare (type fixnum ,n-index)) ,@(sets) - ,@(mapcar #'(lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) + ,@(mapcar (lambda (i val) + `(setf (svref ,n-cache ,i) ,val)) (values-indices) (values-names)) (values))))) @@ -238,8 +481,8 @@ (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)) + ,@(mapcar (lambda (i val) + `(setf (svref ,n-cache ,i) ,val)) (values-indices) default-values)) (values))) @@ -247,6 +490,7 @@ (inits `(unless (boundp ',var-name) (setq ,var-name (make-array ,total-size)))) + #!+sb-show (inits `(setq *hash-caches-initialized-p* t)) `(progn (defvar ,var-name) @@ -256,13 +500,11 @@ ,@(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) - #!+sb-doc - "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form* - Some syntactic sugar for defining a function whose values are cached by - DEFINE-HASH-CACHE." (let ((default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) @@ -276,17 +518,32 @@ (defun ,name ,arg-names ,@decls ,doc - (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)))))))))) + (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)))))))))))) ;;;; package idioms @@ -313,21 +570,10 @@ :format-control "The package ~S has been deleted." :format-arguments (list maybe-result))))) -;;;; miscellany - -;;; FIXME: What is this used for that SYMBOLICATE couldn't be used for instead? -;;; If nothing, replace it. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun concat-pnames (name1 name2) - (declare (symbol name1 name2)) - (if name1 - (intern (concatenate 'simple-string - (symbol-name name1) - (symbol-name name2))) - name2))) +;;;; various operations on names ;;; Is NAME a legal function name? -(defun legal-function-name-p (name) +(defun legal-fun-name-p (name) (or (symbolp name) (and (consp name) (eq (car name) 'setf) @@ -335,37 +581,387 @@ (symbolp (cadr name)) (null (cddr name))))) -;;; Given a function name, return the name for the BLOCK which encloses its -;;; body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET). -(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name)) -(defun function-name-block-name (function-name) - (cond ((symbolp function-name) - function-name) - ((and (consp function-name) - (= (length function-name) 2) - (eq (first function-name) 'setf)) - (second function-name)) +;;; Given a function name, return the name for the BLOCK which +;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET). +(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) +(defun fun-name-block-name (fun-name) + (cond ((symbolp fun-name) + fun-name) + ((and (consp fun-name) + (= (length fun-name) 2) + (eq (first fun-name) 'setf)) + (second fun-name)) (t - (error "not legal as a function name: ~S" function-name)))) - -;;; 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))))) + (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)) + + +;;; 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 +;;; (FLET ((FROB (X) ..)) +;;; (DEFUN FOO (X Y) (FROB X) ..) +;;; (DEFUN BAR (Z) (AND (FROB X) ..))) +;;; can still "work" for cold init: they don't do magical static +;;; linking the way that true toplevel DEFUNs do, but at least they do +;;; 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 + "~@" + name) + ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA + ;; 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) + (named-lambda ,name ,@lambda-rest)))) + +;;;; ONCE-ONLY +;;;; +;;;; "The macro ONCE-ONLY has been around for a long time on various +;;;; systems [..] if you can understand how to write and when to use +;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig, +;;;; _Paradigms of Artificial Intelligence Programming: Case Studies +;;;; in Common Lisp_, p. 853 + +;;; ONCE-ONLY is a utility useful in writing source transforms and +;;; macros. It provides a concise way to wrap a LET around some code +;;; to ensure that some forms are only evaluated once. +;;; +;;; Create a LET* which evaluates each value expression, binding a +;;; temporary variable to the result, and wrapping the LET* around the +;;; result of the evaluation of BODY. Within the body, each VAR is +;;; bound to the corresponding temporary variable. +(defmacro once-only (specs &body body) + (named-let frob ((specs specs) + (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)))))))) + +;;;; various error-checking utilities + +;;; This function can be used as the default value for keyword +;;; arguments that must be always be supplied. Since it is known by +;;; the compiler to never return, it will avoid any compile-time type +;;; warnings that would result from a default value inconsistent with +;;; the declared type. When this function is called, it signals an +;;; error indicating that a required &KEY argument was not supplied. +;;; This function is also useful for DEFSTRUCT slot defaults +;;; corresponding to required arguments. +(declaim (ftype (function () nil) missing-arg)) +(defun missing-arg () + #!+sb-doc + (/show0 "entering MISSING-ARG") + (error "A required &KEY or &OPTIONAL argument was not supplied.")) +;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight +;;; +;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT. +;;; The CL:ASSERT restarts and whatnot expand into a significant +;;; amount of code when you multiply them by 400, so replacing them +;;; with this should reduce the size of the system by enough to be +;;; worthwhile. ENFORCE-TYPE is much less common, but might still be +;;; worthwhile, and since I don't really like CERROR stuff deep in the +;;; 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)) +(defmacro enforce-type (value type) + (once-only ((value value)) + `(unless (typep ,value ',type) + (%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))) + ;;; 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)) +(defun swapped-args-fun (fun) + (declare (type function fun)) + (lambda (x y) + (funcall fun y x))) + +;;; Return the numeric value of a type bound, i.e. an interval bound +;;; more or less in the format of bounds in ANSI's type specifiers, +;;; where a bare numeric value is a closed bound and a list of a +;;; single numeric value is an open bound. +;;; +;;; The "more or less" bit is that the no-bound-at-all case is +;;; represented by NIL (not by * as in ANSI type specifiers); and in +;;; this case we return NIL. +(defun type-bound-number (x) + (if (consp x) + (destructuring-bind (result) x result) + x)) + +;;; some commonly-occuring CONSTANTLY forms +(macrolet ((def-constantly-fun (name 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 +;;; 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)))))) + +;;;; utilities for two-VALUES predicates + +;;; 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), +;;; as SUBTYPEP does.) +;;; * THING is just an atom, and we apply OP (an arity-2 function) +;;; successively to THING and each element of LIST. +(defun any/type (op thing list) + (declare (type function op)) + (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)))))) +(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)))))) + +;;;; 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)) +(defun defprinter-prin1 (name value stream) + (defprinter-prinx #'prin1 name value stream)) +(defun defprinter-princ (name value stream) + (defprinter-prinx #'princ name value stream)) +(defun defprinter-prinx (prinx name value stream) + (declare (type function prinx)) + (when *print-pretty* + (pprint-newline :linear stream)) + (format stream ":~A " name) + (funcall prinx value stream) + (values)) +(defun defprinter-print-space (stream) + (write-char #\space stream)) + +;;; Define some kind of reasonable PRINT-OBJECT method for a +;;; STRUCTURE-OBJECT class. +;;; +;;; NAME is the name of the structure class, and CONC-NAME is the same +;;; as in DEFSTRUCT. +;;; +;;; The SLOT-DESCS describe how each slot should be printed. Each +;;; SLOT-DESC can be a slot name, indicating that the slot should +;;; simply be printed. A SLOT-DESC may also be a list of a slot name +;;; and other stuff. The other stuff is composed of keywords followed +;;; by expressions. The expressions are evaluated with the variable +;;; which is the slot name bound to the value of the slot. These +;;; keywords are defined: +;;; +;;; :PRIN1 Print the value of the expression instead of the slot value. +;;; :PRINC Like :PRIN1, only PRINC the value +;;; :TEST Only print something if the test is true. +;;; +;;; If no printing thing is specified then the slot value is printed +;;; as if by PRIN1. +;;; +;;; 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) + (let ((first? t) + maybe-print-space + (reversed-prints nil) + (stream (gensym "STREAM"))) + (flet ((sref (slot-name) + `(,(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))))))))))) + `(def!method print-object ((structure ,name) ,stream) + (pprint-logical-block (,stream nil) + (print-unreadable-object (structure + ,stream + :type t + :identity ,identity) + ,@(nreverse reversed-prints)))))) -#| -;;; REMOVEME when done testing byte cross-compiler -(defun byte-compiled-foo (x y) - (declare (optimize (speed 0) (debug 1))) - (if x - x - (cons y y))) -|# \ No newline at end of file +;;;; etc. + +;;; Given a pathname, return a corresponding physical pathname. +(defun physicalize-pathname (possibly-logical-pathname) + (if (typep possibly-logical-pathname 'logical-pathname) + (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))