From: William Harold Newman Date: Sun, 5 Nov 2000 21:17:21 +0000 (+0000) Subject: 0.6.8.9: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git 0.6.8.9: tweaked DEFCONSTANTs to be more ANSI-compliant (as required when building using an XC host incorporating changes from the previous commit) and generally cleaner got rid of DEFCONSTANT WRAPPER-LAYOUT completely, which was used only by STRUCTURE-WRAPPER, which is now gone added SB-INT:DEFCONSTANT-EQX to help ANSIfy DEFCONSTANTs merged several small files into primordial-extensions.lisp converted DEFMACRO DEFCONSTANT to use EVAL-WHEN instead of IR1 magic, in order to make it ANSI enough for DEFCONSTANT-EQX to work removed various nested EVAL-WHENs (to help cross-compiler) identified bug IR1-3, added workaround in DO-EVAL-WHEN-STUFF incremented fasl file version (because of mismatch between old IR1 magic %DEFCONSTANT/%%DEFCONSTANT behavior and new EVAL-WHEN %DEFCONSTANT behavior) deleted some unused code fixed (DEFCONSTANT X 1) (DEFVAR X) (SETF X 2) bug --- diff --git a/BUGS b/BUGS index 158cbde..1208231 100644 --- a/BUGS +++ b/BUGS @@ -22,41 +22,17 @@ but instead the program loops endlessly instead of printing the object. -KNOWN BUGS RELATED TO THE IR1 INTERPRETER +NOTES: -(Note: At some point, the pure interpreter (aka the "IR1 interpreter") -will probably go away (replaced by constructs like - (DEFUN EVAL (X) (FUNCALL (COMPILE NIL (LAMBDA ..))))) -and at that time these bugs should go away automatically. Until then, -they'll probably remain, since they're not considered urgent. -After the IR1 interpreter goes away is also the preferred time -to start systematically exterminating cases where debugging -functionality (backtrace, breakpoint, etc.) breaks down, since -getting rid of the IR1 interpreter will reduce the number of -special cases we need to support.) +There is also some information on bugs in the manual page and +in the TODO file. Eventually more such information may move here. -IR1-1: - The FUNCTION special operator doesn't check properly whether its - argument is a function name. E.g. (FUNCTION (X Y)) returns a value - instead of failing with an error. (Later attempting to funcall the - value does cause an error.) - -IR1-2: - COMPILED-FUNCTION-P bogusly reports T for interpreted functions: - * (DEFUN FOO (X) (- 12 X)) - FOO - * (COMPILED-FUNCTION-P #'FOO) - T +The gaps in the number sequence belong to old bugs which have been +fixed. KNOWN BUGS OF NO SPECIAL CLASS: -(Note: - * There is also some information on bugs in the manual page and - in the TODO file. Eventually more such information may move here. - * The gaps in the number sequence belong to old bugs which were - eliminated.) - 2: DEFSTRUCT should almost certainly overwrite the old LAYOUT information instead of just punting when a contradictory structure definition @@ -776,3 +752,63 @@ Error in function C::GET-LAMBDA-TO-COMPILE: (FAIL 12) then requesting a BACKTRACE at the debugger prompt gives no information about where in the user program the problem occurred. + + +KNOWN BUGS RELATED TO THE IR1 INTERPRETER + +(Note: At some point, the pure interpreter (actually a semi-pure +interpreter aka "the IR1 interpreter") will probably go away, replaced +by constructs like + (DEFUN EVAL (X) (FUNCALL (COMPILE NIL (LAMBDA ..))))) +and at that time these bugs should either go away automatically or +become more tractable to fix. Until then, they'll probably remain, +since some of them aren't considered urgent, and the rest are too hard +to fix as long as so many special cases remain. After the IR1 +interpreter goes away is also the preferred time to start +systematically exterminating cases where debugging functionality +(backtrace, breakpoint, etc.) breaks down, since getting rid of the +IR1 interpreter will reduce the number of special cases we need to +support.) + +IR1-1: + The FUNCTION special operator doesn't check properly whether its + argument is a function name. E.g. (FUNCTION (X Y)) returns a value + instead of failing with an error. (Later attempting to funcall the + value does cause an error.) + +IR1-2: + COMPILED-FUNCTION-P bogusly reports T for interpreted functions: + * (DEFUN FOO (X) (- 12 X)) + FOO + * (COMPILED-FUNCTION-P #'FOO) + T + +IR1-3: + Executing + (DEFVAR *SUPPRESS-P* T) + (EVAL '(UNLESS *SUPPRESS-P* + (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) + (FORMAT T "surprise!")))) + prints "surprise!". Probably the entire EVAL-WHEN mechanism ought to be + rewritten from scratch to conform to the ANSI definition, abandoning + the *ALREADY-EVALED-THIS* hack which is used in sbcl-0.6.8.9 (and + in the original CMU CL source, too). This should be easier to do -- + though still nontrivial -- once the various IR1 interpreter special + cases are gone. + +IR1-3a: + EVAL-WHEN's idea of what's a toplevel form is even more screwed up + than the example in IR1-3 would suggest, since COMPILE-FILE and + COMPILE both print both "right now!" messages when compiling the + following code, + (LAMBDA (X) + (COND (X + (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) + (PRINT "yes! right now!")) + "yes!") + (T + (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) + (PRINT "no! right now!")) + "no!"))) + and while EVAL doesn't print the "right now!" messages, the first + FUNCALL on the value returned by EVAL causes both of them to be printed. diff --git a/NEWS b/NEWS index fb26354..6515f4e 100644 --- a/NEWS +++ b/NEWS @@ -536,15 +536,38 @@ changes in sbcl-0.6.9 relative to sbcl-0.6.8: into everyone's system when I do a "cvs update".) When no customize-target-features.lisp file exists, the target *FEATURES* list should be constructed the same way as before. -* The QUIT debugger command is gone, since it did something - rather different than the SB-EXT:QUIT command, and since it never - worked properly outside the main toplevel read/eval/print loop. - Invoking the new TOPLEVEL restart provides the same functionality. -* The GO debugger command is also gone, since you can just invoke - the CONTINUE restart directly instead. -* The TOP debugger command is also gone, since it's redundant with - 'f 0', and since it interfered with abbreviations for the TOPLEVEL - restart. +* fixed bug 1 (error handling before read-eval-print loop starts), and + redid debugger restarts and related debugger commands somewhat while + doing so: + ** The QUIT debugger command is gone, since it did something + rather different than the SB-EXT:QUIT command, and since it never + worked properly outside the main toplevel read/eval/print loop. + Invoking the new TOPLEVEL restart provides the same functionality. + ** The GO debugger command is also gone, since you can just invoke + the CONTINUE restart directly instead. + ** The TOP debugger command is also gone, since it's redundant with the + FRAME 0 command, and since it interfered with abbreviations for the + TOPLEVEL restart. +* DEFCONSTANT has been made more ANSI-compatible (completely ANSI-compatible, + as far as I know): + ** DEFCONSTANT now tests reassignments using EQL, not EQUAL, in order to + warn about behavior which is undefined under the ANSI spec. Note: This + is specified by ANSI, but it's not very popular with programmers. + If it causes you problems, take a look at the new SB-INT:DEFCONSTANT-EQX + macro in the SBCL sources for an example of a workaround which you + might use to make portable ANSI-standard code which does what you want. + ** DEFCONSTANT's implementation is now based on EVAL-WHEN instead of on + pre-ANSI IR1 translation magic, so it does the ANSI-specified thing + when it's used as a non-toplevel form. (This is required in order + to implement the DEFCONSTANT-EQX macro.) +?? fixed bug: (DEFCONSTANT X 1) (DEFVAR X) (SETF X 2) no longer "works". +?? fixed bug 21, a compiler bug re. special variables in closures. One + consequence of this is that ILISP should work better, because idioms like + (LET ((*PACKAGE* ..)) (DO-SOMETHING)) no longer have screwy side-effects. +* The core file version number and fasl file version number have been + incremented, because the old noncompliant DEFCONSTANT behavior involved + calling functions which no longer exist. + ?? signal handling reliability ?? fixed some bugs mentioned in the man page: ?? DEFUN-vs.-DECLAIM diff --git a/make-host-2.sh b/make-host-2.sh index 9100dfe..ff32135 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -89,9 +89,9 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (write *target-object-file-names* :stream s :readably t))) ;; If you're experimenting with the system under a ;; cross-compilation host which supports CMU-CL-style SAVE-LISP, - ;; this can be a good time to run it, - ;; The resulting core isn't used in the normal build, but - ;; can be handy for experimenting with the system. + ;; this can be a good time to run it. The resulting core isn't + ;; used in the normal build, but can be handy for experimenting + ;; with the system. (when (find :sb-show *shebang-features*) #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil) #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")) @@ -101,14 +101,17 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 # # In a fresh host Lisp invocation, load the cross-compiler (in order # to get various definitions that GENESIS needs, not in order to -# cross-compile GENESIS, compile and load GENESIS, then run GENESIS. -# (We use a fresh host Lisp invocation here for basically the same -# reasons we did before when loading and running the cross-compiler.) +# cross-compile GENESIS, then load and run GENESIS. (We use a fresh +# host Lisp invocation here for basically the same reasons we did +# before when loading and running the cross-compiler.) # -# (This second invocation of GENESIS is done because in order to +# (Why do we need this second invocation of GENESIS? In order to # create a .core file, as opposed to just a .h file, GENESIS needs -# symbol table data on the C runtime, which we can get only after the -# C runtime has been built.) +# symbol table data on the C runtime. And we can get that symbol +# data only after the C runtime has been built. Therefore, even +# though we ran GENESIS earlier, we couldn't get it to make a .core +# file at that time; but we needed to run it earlier in order to +# get to where we can write a .core file.) echo //loading and running GENESIS to create cold-sbcl.core $SBCL_XC_HOST <<-'EOF' || exit 1 (setf *print-level* 5 *print-length* 5) diff --git a/make-target-2.sh b/make-target-2.sh index 16f1e9c..0c66d5b 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -13,7 +13,7 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -echo //entering make-host-2.sh +echo //entering make-target-2.sh # Do warm init stuff, e.g. building and loading CLOS, and stuff which # can't be done until CLOS is running. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 53ca135..dc4c6bf 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -683,6 +683,7 @@ retained, possibly temporariliy, because it might be used internally." "ITERATE" "LETF" "LETF*" "ONCE-ONLY" + "DEFENUM" "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE" ;; encapsulation @@ -759,6 +760,10 @@ retained, possibly temporariliy, because it might be used internally." ;; placeholders in a target system "UNCROSS" + ;; might as well be shared among the various files which + ;; need it: + "*EOF-OBJECT*" + ;; misc. utilities used internally "LEGAL-FUNCTION-NAME-P" "FUNCTION-NAME-BLOCK-NAME" @@ -774,6 +779,8 @@ retained, possibly temporariliy, because it might be used internally." "FEATUREP" "FLUSH-STANDARD-OUTPUT-STREAMS" "MAKE-GENSYM-LIST" + "DEFCONSTANT-EQX" + "ABOUT-TO-MODIFY" ;; These could be moved back into SB!EXT if someone has ;; compelling reasons, but hopefully we can get by @@ -1368,8 +1375,7 @@ and even SB-VM have become somewhat blurred over the years." "BYTES" "C-PROCEDURE" "CHECK<=" "CHECK=" "COMPILER-VERSION" "DEALLOCATE-SYSTEM-MEMORY" - "DEFAULT-INTERRUPT" "DEFENUMERATION" - "DEFOPERATOR" "DEFRECORD" + "DEFAULT-INTERRUPT" "DEPORT-BOOLEAN" "DEPORT-INTEGER" "DO-DO-BODY" "DOUBLE-FLOAT-RADIX" "ENABLE-INTERRUPT" "ENUMERATION" diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp index 5fd2fe0..2f60b02 100644 --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -108,13 +108,9 @@ ;;;; What's a bignum? -(eval-when (:compile-toplevel :load-toplevel :execute) ; necessary for DEFTYPE - (defconstant digit-size 32) (defconstant maximum-bignum-length (1- (ash 1 (- 32 sb!vm:type-bits)))) - -) ; EVAL-WHEN ;;;; internal inline routines diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 1a9752d..f9611cf 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -13,8 +13,6 @@ ;;;; constants and types -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant unit-bits sb!vm:word-bits #!+sb-doc "The number of bits to process at a time.") @@ -23,6 +21,9 @@ #!+sb-doc "The maximum number of bits that can be delt with during a single call.") +;;; FIXME: Do we really need EVAL-WHEN around these DEFTYPEs? +(eval-when (:compile-toplevel :load-toplevel :execute) + (deftype unit () `(unsigned-byte ,unit-bits)) diff --git a/src/code/boot-extensions.lisp b/src/code/boot-extensions.lisp index 4dfc372..5506411 100644 --- a/src/code/boot-extensions.lisp +++ b/src/code/boot-extensions.lisp @@ -11,18 +11,46 @@ (in-package "SB!EXT") -;;; 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 +;;; 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")) +(defvar *cl-package* (find-package "COMMON-LISP")) +(defvar *keyword-package* (find-package "KEYWORD")) + +;;; a helper function for various macros which expect clauses of a +;;; given length, etc. +;;; +;;; KLUDGE: 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. +(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)) + (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)))) ;;;; the COLLECT macro -;;; helper functions for COLLECT, which become the expanders of the MACROLET -;;; definitions created by COLLECT +;;; helper functions for COLLECT, which become the expanders of the +;;; MACROLET definitions created by COLLECT ;;; ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros. ;;; @@ -124,9 +152,9 @@ `(labels ((,name ,(mapcar #'first binds) ,@body)) (,name ,@(mapcar #'second binds)))) -;;; Once-Only is a utility useful in writing source transforms and macros. -;;; It provides an easy way to wrap a LET around some code to ensure that some -;;; forms are only evaluated once. +;;; 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. (defmacro once-only (specs &body body) #!+sb-doc "Once-Only ({(Var Value-Expression)}*) Form* @@ -181,8 +209,9 @@ ;; 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: + ;; 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)))) diff --git a/src/code/byte-types.lisp b/src/code/byte-types.lisp index 6e30dc0..4dae88c 100644 --- a/src/code/byte-types.lisp +++ b/src/code/byte-types.lisp @@ -17,8 +17,7 @@ `(integer 0 ,(1- most-positive-fixnum))) ;;; KLUDGE: bare numbers, no documentation, ick.. -- WHN 19990701 -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant max-pc (1- (ash 1 24)))) +(defconstant max-pc (1- (ash 1 24))) (deftype pc () `(integer 0 ,max-pc)) diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp index 23326d0..fac06dd 100644 --- a/src/code/debug-info.lisp +++ b/src/code/debug-info.lisp @@ -16,8 +16,8 @@ ;;;; We represent the place where some value is stored with a SC-OFFSET, ;;;; which is the SC number and offset encoded as an integer. -(defconstant sc-offset-scn-byte (byte 5 0)) -(defconstant sc-offset-offset-byte (byte 22 5)) +(defconstant-eqx sc-offset-scn-byte (byte 5 0) #'equalp) +(defconstant-eqx sc-offset-offset-byte (byte 22 5) #'equalp) (def!type sc-offset () '(unsigned-byte 27)) (defmacro make-sc-offset (scn offset) @@ -73,13 +73,13 @@ ;;;; ...more ;;;; tuples... -(defconstant compiled-debug-block-nsucc-byte (byte 2 0)) +(defconstant-eqx compiled-debug-block-nsucc-byte (byte 2 0) #'equalp) (defconstant compiled-debug-block-elsewhere-p #b00000100) -(defconstant compiled-code-location-kind-byte (byte 3 0)) -(defconstant compiled-code-location-kinds - '#(:unknown-return :known-return :internal-error :non-local-exit - :block-start :call-site :single-value-return :non-local-entry)) +(defconstant-eqx compiled-code-location-kind-byte (byte 3 0) #'equalp) +(defparameter *compiled-code-location-kinds* + #(:unknown-return :known-return :internal-error :non-local-exit + :block-start :call-site :single-value-return :non-local-entry)) ;;;; DEBUG-FUNCTION objects @@ -234,31 +234,28 @@ Well, I guess you need to at least know which function is an XEP for the real function (which would be useful info anyway). |# -;;; Following are definitions of bit-fields in the first byte of the minimal -;;; debug function: +;;; The following are definitions of bit-fields in the first byte of +;;; the minimal debug function: (defconstant minimal-debug-function-name-symbol 0) (defconstant minimal-debug-function-name-packaged 1) (defconstant minimal-debug-function-name-uninterned 2) (defconstant minimal-debug-function-name-component 3) -(defconstant minimal-debug-function-name-style-byte (byte 2 0)) -(defconstant minimal-debug-function-kind-byte (byte 3 2)) -(defconstant minimal-debug-function-kinds - '#(nil :optional :external :top-level :cleanup)) +(defconstant-eqx minimal-debug-function-name-style-byte (byte 2 0) #'equalp) +(defconstant-eqx minimal-debug-function-kind-byte (byte 3 2) #'equalp) +(defparameter *minimal-debug-function-kinds* + #(nil :optional :external :top-level :cleanup)) (defconstant minimal-debug-function-returns-standard 0) (defconstant minimal-debug-function-returns-specified 1) (defconstant minimal-debug-function-returns-fixed 2) -(defconstant minimal-debug-function-returns-byte (byte 2 5)) +(defconstant-eqx minimal-debug-function-returns-byte (byte 2 5) #'equalp) ;;; The following are bit-flags in the second byte of the minimal debug ;;; function: - -;;; If true, wrap (SETF ...) around the name. +;;; * If true, wrap (SETF ...) around the name. (defconstant minimal-debug-function-setf-bit (ash 1 0)) - -;;; If true, there is a NFP. +;;; * If true, there is a NFP. (defconstant minimal-debug-function-nfp-bit (ash 1 1)) - -;;; If true, variables (hence arguments) have been dumped. +;;; * If true, variables (hence arguments) have been dumped. (defconstant minimal-debug-function-variables-bit (ash 1 2)) ;;;; debug source diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 281128e..ae9439d 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1813,7 +1813,7 @@ (let* ((locations (dotimes (k (sb!c::read-var-integer blocks i) (result locations-buffer)) - (let ((kind (svref sb!c::compiled-code-location-kinds + (let ((kind (svref sb!c::*compiled-code-location-kinds* (aref+ blocks i))) (pc (+ last-pc (sb!c::read-var-integer blocks i))) @@ -2003,7 +2003,7 @@ (if (logtest flags sb!c::minimal-debug-function-setf-bit) `(setf ,base) base)) - :kind (svref sb!c::minimal-debug-function-kinds + :kind (svref sb!c::*minimal-debug-function-kinds* (ldb sb!c::minimal-debug-function-kind-byte options)) :variables (when vars-p @@ -3622,7 +3622,7 @@ #!+x86 sb!vm::ebx-offset))) (nargs (make-lisp-obj (sb!vm:context-register scp sb!vm::nargs-offset))) - (reg-arg-offsets '#.sb!vm::register-arg-offsets) + (reg-arg-offsets '#.sb!vm::*register-arg-offsets*) (results nil)) (without-gcing (dotimes (arg-num nargs) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 5a443c9..2f86b39 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1228,10 +1228,10 @@ (%delayed-get-compiler-layout ,(dd-name defstruct))) ,@(when n-raw-data `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data))) - ,@(mapcar #'(lambda (dsd value) - (multiple-value-bind (accessor index data) - (slot-accessor-form defstruct dsd temp n-raw-data) - `(setf (,accessor ,data ,index) ,value))) + ,@(mapcar (lambda (dsd value) + (multiple-value-bind (accessor index data) + (slot-accessor-form defstruct dsd temp n-raw-data) + `(setf (,accessor ,data ,index) ,value))) (dd-slots defstruct) values) ,temp)))) @@ -1269,7 +1269,7 @@ defstruct (dd-default-constructor defstruct) (arglist) (vals) (types) (vals)))) -;;; Given a structure and a BOA constructor spec, call Creator with +;;; Given a structure and a BOA constructor spec, call CREATOR with ;;; the appropriate args to make a constructor. (defun create-boa-constructor (defstruct boa creator) (multiple-value-bind (req opt restp rest keyp keys allowp aux) diff --git a/src/code/early-defboot.lisp b/src/code/early-defboot.lisp deleted file mode 100644 index d69b6aa..0000000 --- a/src/code/early-defboot.lisp +++ /dev/null @@ -1,104 +0,0 @@ -;;;; target bootstrapping stuff which needs to be visible on the -;;;; cross-compilation host too - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!EXT") - -;;; helper function for various macros which expect clauses of a given -;;; length, etc. -;;; -;;; KLUDGE: 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. -(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)) - (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)))) - -;;;; DO-related stuff which needs to be visible on the cross-compilation host - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun do-do-body (varlist endlist decls-and-code bind step name block) - (let* ((r-inits nil) ; accumulator for reversed list - (r-steps nil) ; accumulator for reversed list - (label-1 (gensym)) - (label-2 (gensym))) - ;; Check for illegal old-style DO. - (when (or (not (listp varlist)) (atom endlist)) - (error "Ill-formed ~S -- possibly illegal old style DO?" name)) - ;; Parse VARLIST to get R-INITS and R-STEPS. - (dolist (v varlist) - (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be defined - ;; in terms of CL:SETF, and CL:SETF can be defined in terms of - ;; CL:DO, and CL:DO can be defined in terms of the current - ;; function.) - (push-on-r-inits (x) - (setq r-inits (cons x r-inits))) - ;; common error-handling - (illegal-varlist () - (error "~S is an illegal form for a ~S varlist." v name))) - (cond ((symbolp v) (push-on-r-inits v)) - ((listp v) - (unless (symbolp (first v)) - (error "~S step variable is not a symbol: ~S" - name - (first v))) - (let ((lv (length v))) - ;; (We avoid using CL:CASE here so that CL:CASE can be - ;; defined in terms of CL:SETF, and CL:SETF can be defined - ;; in terms of CL:DO, and CL:DO can be defined in terms of - ;; the current function.) - (cond ((= lv 1) - (push-on-r-inits (first v))) - ((= lv 2) - (push-on-r-inits v)) - ((= lv 3) - (push-on-r-inits (list (first v) (second v))) - (setq r-steps (list* (third v) (first v) r-steps))) - (t (illegal-varlist))))) - (t (illegal-varlist))))) - ;; Construct the new form. - (multiple-value-bind (code decls) (parse-body decls-and-code nil) - `(block ,block - (,bind ,(nreverse r-inits) - ,@decls - (tagbody - (go ,label-2) - ,label-1 - ,@code - (,step ,@(nreverse r-steps)) - ,label-2 - (unless ,(first endlist) (go ,label-1)) - (return-from ,block (progn ,@(rest endlist)))))))))) - -(defmacro do-anonymous (varlist endlist &rest body) - #!+sb-doc - "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* - Like DO, but has no implicit NIL block. Each Var is initialized in parallel - to the value of the specified Init form. On subsequent iterations, the Vars - are assigned the value of the Step form (if any) in parallel. The Test is - evaluated before each evaluation of the body Forms. When the Test is true, - the Exit-Forms are evaluated as a PROGN, with the result being the value - of the DO." - (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym))) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 1fa53ce..68f5e25 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -18,6 +18,9 @@ (in-package "SB!EXT") +;;; 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 ;;; @@ -55,20 +58,6 @@ (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. -(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))) - ;;;; miscellaneous iteration extensions (defmacro dovector ((elt vector &optional result) &rest forms) @@ -359,6 +348,27 @@ (declaim (ftype (function (index) list) make-gensym-list)) (defun make-gensym-list (n) (loop repeat n collect (gensym))) + +;;; ANSI guarantees that some symbols are self-evaluating. This +;;; function is to be called just before a change which would affect +;;; that. (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) + (declare (type symbol symbol)) + (cond ((eq symbol t) + (error "Veritas aeterna. (can't change T)")) + ((eq symbol nil) + (error "Nihil ex nihil. (can't change NIL)")) + ((keywordp symbol) + (error "Keyword values can't be changed.")) + ;; (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.) + )) #| ;;; REMOVEME when done testing byte cross-compiler diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 879125c..900e1ab 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -9,7 +9,7 @@ (in-package "SB!EVAL") -;;; This flag is used by EVAL-WHEN to keep track of when code has already been -;;; evaluated so that it can avoid multiple evaluation of nested EVAL-WHEN -;;; (COMPILE)s. +;;; This flag is used by EVAL-WHEN to keep track of when code has +;;; already been evaluated so that it can avoid multiple evaluation of +;;; nested EVAL-WHEN (COMPILE)s. (defvar *already-evaled-this* nil) diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index f99ec5b..ee10e95 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -16,7 +16,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant float-trap-alist +(defparameter *float-trap-alist* (list (cons :underflow float-underflow-trap-bit) (cons :overflow float-overflow-trap-bit) (cons :inexact float-inexact-trap-bit) @@ -24,20 +24,19 @@ (cons :divide-by-zero float-divide-by-zero-trap-bit) #!+x86 (cons :denormalized-operand float-denormal-trap-bit))) -;;; Return a mask with all the specified float trap bits set. -(defun float-trap-mask (names) - (reduce #'logior - (mapcar #'(lambda (x) - (or (cdr (assoc x float-trap-alist)) - (error "Unknown float trap kind: ~S." x))) - names))) - -(defconstant rounding-mode-alist +(defparameter *rounding-mode-alist* (list (cons :nearest float-round-to-nearest) (cons :zero float-round-to-zero) (cons :positive-infinity float-round-to-positive) (cons :negative-infinity float-round-to-negative))) +;;; Return a mask with all the specified float trap bits set. +(defun float-trap-mask (names) + (reduce #'logior + (mapcar #'(lambda (x) + (or (cdr (assoc x *float-trap-alist*)) + (error "unknown float trap kind: ~S" x))) + names))) ); Eval-When (Compile Load Eval) ;;; interpreter stubs @@ -82,8 +81,8 @@ (setf (ldb float-traps-byte modes) (float-trap-mask traps))) (when round-p (setf (ldb float-rounding-mode modes) - (or (cdr (assoc rounding-mode rounding-mode-alist)) - (error "Unknown rounding mode: ~S." rounding-mode)))) + (or (cdr (assoc rounding-mode *rounding-mode-alist*)) + (error "unknown rounding mode: ~S" rounding-mode)))) (when current-x-p (setf (ldb float-exceptions-byte modes) (float-trap-mask current-exceptions))) @@ -112,13 +111,13 @@ ,@(mapcar #'(lambda (x) `(when (logtest bits ,(cdr x)) (res ',(car x)))) - float-trap-alist) + *float-trap-alist*) (res)))) (frob)))) (let ((modes (floating-point-modes))) `(:traps ,(exc-keys (ldb float-traps-byte modes)) :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes) - rounding-mode-alist)) + *rounding-mode-alist*)) :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes)) :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes)) :fast-mode ,(logtest float-fast-bit modes))))) diff --git a/src/code/format-time.lisp b/src/code/format-time.lisp index f9199e1..e23ff4b 100644 --- a/src/code/format-time.lisp +++ b/src/code/format-time.lisp @@ -1,4 +1,4 @@ -;;; time printing routines built upon the Common Lisp FORMAT function +;;;; time printing routines built upon the Common Lisp FORMAT function ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -11,32 +11,28 @@ (in-package "SB!EXT") -(defconstant abbrev-weekday-table - '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) +(defparameter *abbrev-weekday-table* + #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) -(defconstant long-weekday-table - '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" - "Sunday")) +(defparameter *long-weekday-table* + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) -(defconstant abbrev-month-table - '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" - "Dec")) +(defparameter *abbrev-month-table* + #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) -(defconstant long-month-table - '#("January" "February" "March" "April" "May" "June" "July" "August" - "September" "October" "November" "December")) +(defparameter *long-month-table* + #("January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December")) -;;; The timezone-table is incomplete but workable. +;;; The timezone table is incomplete but workable. +(defparameter *timezone-table* + #("GMT" "" "" "" "" "EST" "CST" "MST" "PST")) -(defconstant timezone-table - '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST")) - -(defconstant daylight-table - '#(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT")) - -;;; Valid-Destination-P ensures the destination stream is okay -;;; for the Format function. +(defparameter *daylight-table* + #(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT")) +;;; VALID-DESTINATION-P ensures the destination stream is okay for the +;;; FORMAT function. (defun valid-destination-p (destination) (or (not destination) (eq destination 't) @@ -44,8 +40,6 @@ (and (stringp destination) (array-has-fill-pointer-p destination)))) -;;; Format-Universal-Time - External. - ;;; CMU CL made the default style :SHORT here. I've changed that to :LONG, on ;;; the theory that since the 8/7/1999 style is hard to decode unambiguously, ;;; you should have to ask for it explicitly. (I prefer YYYYMMDD myself, since @@ -58,7 +52,7 @@ ;;; 8601 formats (like e.g. :iso-8601 and :iso-8601-short) and migrate ;;; slowly towards ISO dates in the user code... ;;; The :ISO-8601 and :ISO-8601-SHORT options sound sensible to me. Maybe -;;; someone will do them for CMU CL and we can steal them here. +;;; someone will do them for CMU CL and we can steal them for SBCL. (defun format-universal-time (destination universal-time &key (timezone nil) @@ -74,7 +68,7 @@ destination which can be accepted by the Format function. The timezone keyword is an integer specifying hours west of Greenwich. The style keyword can be :SHORT (numeric date), :LONG (months and - weekdays expressed as words), :ABBREVIATED (like :long but words are + weekdays expressed as words), :ABBREVIATED (like :LONG but words are abbreviated), or :GOVERNMENT (of the form \"XX Month XXXX XX:XX:XX\") The keyword argument DATE-FIRST, if nil, will print the time first instead of the date (the default). The PRINT- keywords, if nil, inhibit @@ -97,9 +91,9 @@ (let ((time-string "~2,'0D:~2,'0D") (date-string (case style - (:short "~D/~D/~D") ;; MM/DD/Y - ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y - (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y + (:short "~D/~D/~D") ;; MM/DD/Y + ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y + (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y (t (error "~A: Unrecognized :style keyword value." style)))) (time-args @@ -108,18 +102,18 @@ (:short (list month day year)) (:abbreviated - (list (svref abbrev-month-table (1- month)) day year)) + (list (svref *abbrev-month-table* (1- month)) day year)) (:long - (list (svref long-month-table (1- month)) day year)) + (list (svref *long-month-table* (1- month)) day year)) (:government - (list day (svref abbrev-month-table (1- month)) + (list day (svref *abbrev-month-table* (1- month)) year))))) (declare (simple-string time-string date-string)) (when print-weekday (push (case style - ((:short :long) (svref long-weekday-table dow)) - (:abbreviated (svref abbrev-weekday-table dow)) - (:government (svref abbrev-weekday-table dow))) + ((:short :long) (svref *long-weekday-table* dow)) + (:abbreviated (svref *abbrev-weekday-table* dow)) + (:government (svref *abbrev-weekday-table* dow))) date-args) (setq date-string (concatenate 'simple-string "~A, " date-string))) @@ -149,7 +143,7 @@ (if (and (integerp tz) (or (and dst (= tz 0)) (<= 5 tz 8))) - (svref (if dst daylight-table timezone-table) tz) + (svref (if dst *daylight-table* *timezone-table*) tz) (multiple-value-bind (rest seconds) (truncate (* tz 60 60) 60) (multiple-value-bind (hours minutes) (truncate rest 60) (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]" @@ -160,7 +154,6 @@ (not (zerop seconds)) (abs seconds)))))) -;;; Format-Decoded-Time - External. (defun format-decoded-time (destination seconds minutes hours day month year &key (timezone nil) @@ -171,14 +164,14 @@ (print-timezone t) (print-weekday t)) #!+sb-doc - "Format-Decoded-Time formats a string containing decoded-time + "FORMAT-DECODED-TIME formats a string containing decoded time expressed in a humanly-readable manner. The destination is any - destination which can be accepted by the Format function. The + destination which can be accepted by the FORMAT function. The timezone keyword is an integer specifying hours west of Greenwich. - The style keyword can be :short (numeric date), :long (months and - weekdays expressed as words), or :abbreviated (like :long but words are - abbreviated). The keyword date-first, if nil, will cause the time - to be printed first instead of the date (the default). The print- + The style keyword can be :SHORT (numeric date), :LONG (months and + weekdays expressed as words), or :ABBREVIATED (like :LONG but words are + abbreviated). The keyword DATE-FIRST, if NIL, will cause the time + to be printed first instead of the date (the default). The PRINT- keywords, if nil, inhibit the printing of certain semi-obvious parts of the string." (unless (valid-destination-p destination) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index ce46024..7058209 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -61,7 +61,7 @@ (setf (gethash name *alien-type-classes*) (make-alien-type-class :name name :include include))))) -(defconstant method-slot-alist +(defparameter *method-slot-alist* '((:unparse . alien-type-class-unparse) (:type= . alien-type-class-type=) (:subtypep . alien-type-class-subtypep) @@ -76,13 +76,13 @@ (:result-tn . alien-type-class-result-tn))) (defun method-slot (method) - (cdr (or (assoc method method-slot-alist) + (cdr (or (assoc method *method-slot-alist*) (error "no method ~S" method)))) ) ; EVAL-WHEN -;;; We define a keyword "BOA" constructor so that we can reference the slot -;;; names in init forms. +;;; We define a keyword "BOA" constructor so that we can reference the +;;; slot names in init forms. (def!macro def-alien-type-class ((name &key include include-args) &rest slots) (let ((defstruct-name (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE")))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 44ae73a..88c91ec 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -790,11 +790,11 @@ ;;; A list of all the float formats, in order of decreasing precision. (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant float-formats + (defparameter *float-formats* '(long-float double-float single-float short-float))) ;;; The type of a float format. -(deftype float-format () `(member ,@float-formats)) +(deftype float-format () `(member ,@*float-formats*)) #!+negative-zero-is-not-zero (defun make-numeric-type (&key class format (complexp :real) low high @@ -1267,19 +1267,19 @@ ;;; either one is null, return NIL. (defun float-format-max (f1 f2) (when (and f1 f2) - (dolist (f float-formats (error "Bad float format: ~S." f1)) + (dolist (f *float-formats* (error "bad float format: ~S" f1)) (when (or (eq f f1) (eq f f2)) (return f))))) -;;; Return the result of an operation on Type1 and Type2 according to +;;; Return the result of an operation on TYPE1 and TYPE2 according to ;;; the rules of numeric contagion. This is always NUMBER, some float ;;; format (possibly complex) or RATIONAL. Due to rational ;;; canonicalization, there isn't much we can do here with integers or ;;; rational complex numbers. ;;; -;;; If either argument is not a Numeric-Type, then return NUMBER. This +;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This ;;; is useful mainly for allowing types that are technically numbers, -;;; but not a Numeric-Type. +;;; but not a NUMERIC-TYPE. (defun numeric-contagion (type1 type2) (if (and (numeric-type-p type1) (numeric-type-p type2)) (let ((class1 (numeric-type-class type1)) diff --git a/src/code/lisp-stream.lisp b/src/code/lisp-stream.lisp index f78bf06..5a34f9f 100644 --- a/src/code/lisp-stream.lisp +++ b/src/code/lisp-stream.lisp @@ -11,8 +11,7 @@ (in-package "SB!IMPL") -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant in-buffer-length 512 "the size of a stream in-buffer")) +(defconstant in-buffer-length 512 "the size of a stream in-buffer") (deftype in-buffer-type () `(simple-array (unsigned-byte 8) (,in-buffer-length))) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 362bce1..c07cc9e 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -76,9 +76,9 @@ #!+high-security-support (defmacro-mundanely check-type-var (place type-var &optional type-string) #!+sb-doc - "Signals an error of type type-error if the contents of place are not of the - specified type to which the type-var evaluates. If an error is signaled, - this can only return if STORE-VALUE is invoked. It will store into place + "Signals an error of type TYPE-ERROR if the contents of PLACE are not of the + specified type to which the TYPE-VAR evaluates. If an error is signaled, + this can only return if STORE-VALUE is invoked. It will store into PLACE and start over." (let ((place-value (gensym)) (type-value (gensym))) @@ -90,32 +90,52 @@ ;;;; DEFCONSTANT -(defmacro-mundanely defconstant (var val &optional doc) +(defmacro-mundanely defconstant (name value &optional documentation) #!+sb-doc - "For defining global constants at top level. The DEFCONSTANT says that the - value is constant and may be compiled into code. If the variable already has - a value, and this is not equal to the init, an error is signalled. The third - argument is an optional documentation string for the variable." - `(sb!c::%defconstant ',var ,val ',doc)) + "For defining global constants. The DEFCONSTANT says that the value + is constant and may be compiled into code. If the variable already has + a value, and this is not EQL to the init, the code is not portable + (undefined behavior). The third argument is an optional documentation + string for the variable." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!c::%defconstant ',name ,value ',documentation))) + +;;; (to avoid "undefined function" warnings when cross-compiling) +(sb!xc:proclaim '(ftype function sb!c::%defconstant)) -;;; These are like the other %MUMBLEs except that we currently -;;; actually do something interesting at load time, namely checking -;;; whether the constant is being redefined. +;;; the guts of DEFCONSTANT (defun sb!c::%defconstant (name value doc) - (sb!c::%%defconstant name value doc)) -#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defconstant)) ; to avoid - ; undefined function warnings -(defun sb!c::%%defconstant (name value doc) + (/show "doing %DEFCONSTANT" name value doc) + (unless (symbolp name) + (error "constant name not a symbol: ~S" name)) + (about-to-modify name) + (let ((kind (info :variable :kind name))) + (case kind + (:constant + ;; Note 1: This behavior (discouraging any non-EQL + ;; modification) is unpopular, but it is specified by ANSI + ;; (i.e. ANSI says a non-EQL change has undefined + ;; consequences). If people really want bindings which are + ;; constant in some sense other than EQL, I suggest either just + ;; using DEFVAR (which is usually appropriate, despite the + ;; un-mnemonic name), or defining something like + ;; SB-INT:DEFCONSTANT-EQX (which is occasionally more + ;; appropriate). -- WHN 2000-11-03 + (unless (eql value + (info :variable :constant-value name)) + (cerror "Go ahead and change the value." + "The constant ~S is being redefined." + name))) + (:global + ;; (This is OK -- undefined variables are of this kind. So we + ;; don't warn or error or anything, just fall through.) + ) + (t (warn "redefining ~(~A~) ~S to be a constant" kind name)))) (when doc (setf (fdocumentation name 'variable) doc)) - (when (boundp name) - (unless (equalp (symbol-value name) value) - (cerror "Go ahead and change the value." - "The constant ~S is being redefined." - name))) (setf (symbol-value name) value) (setf (info :variable :kind name) :constant) - (clear-info :variable :constant-value name) + (setf (info :variable :constant-value name) value) name) ;;;; DEFINE-COMPILER-MACRO diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp new file mode 100644 index 0000000..63bb972 --- /dev/null +++ b/src/code/primordial-extensions.lisp @@ -0,0 +1,171 @@ +;;;; various user-level definitions which need to be done particularly +;;;; early + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!INT") + + +;;;; DO-related stuff which needs to be visible on the cross-compilation host + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun do-do-body (varlist endlist decls-and-code bind step name block) + (let* ((r-inits nil) ; accumulator for reversed list + (r-steps nil) ; accumulator for reversed list + (label-1 (gensym)) + (label-2 (gensym))) + ;; Check for illegal old-style DO. + (when (or (not (listp varlist)) (atom endlist)) + (error "Ill-formed ~S -- possibly illegal old style DO?" name)) + ;; Parse VARLIST to get R-INITS and R-STEPS. + (dolist (v varlist) + (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be defined + ;; in terms of CL:SETF, and CL:SETF can be defined in terms of + ;; CL:DO, and CL:DO can be defined in terms of the current + ;; function.) + (push-on-r-inits (x) + (setq r-inits (cons x r-inits))) + ;; common error-handling + (illegal-varlist () + (error "~S is an illegal form for a ~S varlist." v name))) + (cond ((symbolp v) (push-on-r-inits v)) + ((listp v) + (unless (symbolp (first v)) + (error "~S step variable is not a symbol: ~S" + name + (first v))) + (let ((lv (length v))) + ;; (We avoid using CL:CASE here so that CL:CASE can be + ;; defined in terms of CL:SETF, and CL:SETF can be defined + ;; in terms of CL:DO, and CL:DO can be defined in terms of + ;; the current function.) + (cond ((= lv 1) + (push-on-r-inits (first v))) + ((= lv 2) + (push-on-r-inits v)) + ((= lv 3) + (push-on-r-inits (list (first v) (second v))) + (setq r-steps (list* (third v) (first v) r-steps))) + (t (illegal-varlist))))) + (t (illegal-varlist))))) + ;; Construct the new form. + (multiple-value-bind (code decls) (parse-body decls-and-code nil) + `(block ,block + (,bind ,(nreverse r-inits) + ,@decls + (tagbody + (go ,label-2) + ,label-1 + ,@code + (,step ,@(nreverse r-steps)) + ,label-2 + (unless ,(first endlist) (go ,label-1)) + (return-from ,block (progn ,@(rest endlist)))))))))) + +(defmacro do-anonymous (varlist endlist &rest body) + #!+sb-doc + "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* + Like DO, but has no implicit NIL block. Each Var is initialized in parallel + to the value of the specified Init form. On subsequent iterations, the Vars + are assigned the value of the Step form (if any) in parallel. The Test is + evaluated before each evaluation of the body Forms. When the Test is true, + the Exit-Forms are evaluated as a PROGN, with the result being the value + of the DO." + (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym))) + +;;;; miscellany + +;;; Concatenate together the names of some strings and symbols, +;;; producing a symbol in the current package. +(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))) + +;;; Give names to elements of a numeric sequence. +(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) + &rest identifiers) + (let ((results nil) + (index 0) + (start (eval start)) + (step (eval step))) + (dolist (id identifiers) + (when id + (multiple-value-bind (root docs) + (if (consp id) + (values (car id) (cdr id)) + (values id nil)) + ;; (This could be SYMBOLICATE, except that due to + ;; bogobootstrapping issues SYMBOLICATE isn't defined yet.) + (push `(defconstant ,(symbolicate prefix root suffix) + ,(+ start (* step index)) + ,@docs) + results))) + (incf index)) + `(progn + ,@(nreverse results)))) + +;;; generalization of DEFCONSTANT to values which are the same not +;;; under EQL but under e.g. EQUAL or EQUALP +;;; +;;; DEFCONSTANT-EQX is to be used instead of DEFCONSTANT for values +;;; which are appropriately compared using the function given by the +;;; EQX argument instead of EQL. +;;; +;;; Note: Be careful when using this macro, since it's easy to +;;; unintentionally pessimize your code. A good time to use this macro +;;; is when the values defined will be fed into optimization +;;; transforms and never actually appear in the generated code; this +;;; is especially common when defining BYTE expressions. Unintentional +;;; pessimization can result when the values defined by this macro are +;;; actually used in generated code: because of the way that the +;;; dump/load system works, you'll typically get one copy of consed +;;; structure for each object file which contains code referring to +;;; the value, plus perhaps one more copy bound to the SYMBOL-VALUE of +;;; the constant. If you don't want that to happen, you should +;;; probably use DEFPARAMETER instead. +(defmacro defconstant-eqx (symbol expr eqx &optional doc) + (let ((expr-tmp (gensym "EXPR-TMP-"))) + `(progn + ;; When we're building the cross-compiler, and in most + ;; situations even when we're running the cross-compiler, + ;; all we need is a nice portable definition in terms of the + ;; ANSI Common Lisp operations. + (eval-when (:compile-toplevel :load-toplevel :execute) + (let ((,expr-tmp ,expr)) + (unless (and (boundp ',symbol) + (constantp ',symbol) + (funcall ,eqx (symbol-value ',symbol) ,expr-tmp)) + (defconstant ,symbol ,expr ,@(when doc `(,doc)))))) + ;; The #+SB-XC :COMPILE-TOPLEVEL situation is special, since we + ;; want to define the symbol not just in the cross-compilation + ;; host Lisp (which was handled above) but also in the + ;; cross-compiler (which we will handle now). + ;; + ;; KLUDGE: It would probably be possible to do this fairly + ;; cleanly, in a way parallel to the code above, if we had + ;; SB!XC:FOO versions of all the primitives CL:FOO used above + ;; (e.g. SB!XC:BOUNDP, SB!XC:SYMBOL-VALUE, and + ;; SB!XC:DEFCONSTANT), and took care to call them. But right + ;; now we just hack around in the guts of the cross-compiler + ;; instead. -- WHN 2000-11-03 + #+sb-xc + (eval-when (:compile-toplevel) + (let ((,expr-tmp ,expr)) + (unless (and (eql (info :variable :kind ',symbol) :constant) + (funcall ,eqx + (info :variable :constant-value ',symbol) + ,expr-tmp)) + (sb!c::%defconstant ',symbol ,expr-tmp ,doc))))))) diff --git a/src/code/print.lisp b/src/code/print.lisp index 0c19b98..1f61fcc 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -602,8 +602,6 @@ (declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit)) *character-attributes*)) -(eval-when (:compile-toplevel :load-toplevel :execute) - ;;; Constants which are a bit-mask for each interesting character attribute. (defconstant other-attribute (ash 1 0)) ; Anything else legal. (defconstant number-attribute (ash 1 1)) ; A numeric digit. @@ -615,9 +613,11 @@ (defconstant slash-attribute (ash 1 7)) ; / (defconstant funny-attribute (ash 1 8)) ; Anything illegal. -;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters that -;;; don't need to be escaped (according to READTABLE-CASE.) -(defconstant attribute-names +(eval-when (:compile-toplevel :load-toplevel :execute) + +;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters +;;; that don't need to be escaped (according to READTABLE-CASE.) +(defparameter *attribute-names* `((number . number-attribute) (lowercase . lowercase-attribute) (uppercase . uppercase-attribute) (letter . letter-attribute) (sign . sign-attribute) (extension . extension-attribute) @@ -688,9 +688,10 @@ (the fixnum (logand (logior ,@(mapcar - #'(lambda (x) - (or (cdr (assoc x attribute-names)) - (error "Blast!"))) + (lambda (x) + (or (cdr (assoc x + *attribute-names*)) + (error "Blast!"))) attributes)) bits))))) (digitp () diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 4f78e13..f37d54f 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -55,21 +55,20 @@ ;;;; constants for character attributes. These are all as in the manual. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant whitespace 0) - (defconstant terminating-macro 1) - (defconstant escape 2) - (defconstant constituent 3) - (defconstant constituent-dot 4) - (defconstant constituent-expt 5) - (defconstant constituent-slash 6) - (defconstant constituent-digit 7) - (defconstant constituent-sign 8) - ;; the "9" entry intentionally left blank for some reason -- WHN 19990806 - (defconstant multiple-escape 10) - (defconstant package-delimiter 11) - ;; a fake attribute for use in read-unqualified-token - (defconstant delimiter 12)) +(defconstant whitespace 0) +(defconstant terminating-macro 1) +(defconstant escape 2) +(defconstant constituent 3) +(defconstant constituent-dot 4) +(defconstant constituent-expt 5) +(defconstant constituent-slash 6) +(defconstant constituent-digit 7) +(defconstant constituent-sign 8) +;; the "9" entry intentionally left blank for some reason -- WHN 19990806 +(defconstant multiple-escape 10) +(defconstant package-delimiter 11) +;; a fake attribute for use in read-unqualified-token +(defconstant delimiter 12) ;;;; macros and functions for character tables @@ -233,10 +232,7 @@ ;;;; definitions to support internal programming conventions -;;; FIXME: DEFCONSTANT doesn't actually work this way.. -(defconstant eof-object '(*eof*)) - -(defmacro eofp (char) `(eq ,char eof-object)) +(defmacro eofp (char) `(eq ,char *eof-object*)) (defun flush-whitespace (stream) ;; This flushes whitespace chars, returning the last char it read (a @@ -349,15 +345,15 @@ (defun inchpeek-read-buffer () (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*)) - eof-object + *eof-object* (elt *read-buffer* *inch-ptr*))) (defun inch-read-buffer () (if (>= *inch-ptr* *ouch-ptr*) - eof-object - (prog1 - (elt *read-buffer* *inch-ptr*) - (incf *inch-ptr*)))) + *eof-object* + (prog1 + (elt *read-buffer* *inch-ptr*) + (incf *inch-ptr*)))) (defmacro unread-buffer () `(decf *inch-ptr*)) @@ -394,9 +390,9 @@ that followed the object." (cond (recursivep - ;; Loop for repeating when a macro returns nothing. + ;; a loop for repeating when a macro returns nothing (loop - (let ((char (read-char stream eof-error-p eof-object))) + (let ((char (read-char stream eof-error-p *eof-object*))) (cond ((eofp char) (return eof-value)) ((whitespacep char)) (t @@ -425,7 +421,7 @@ the manual." (prog1 (read-preserving-whitespace stream eof-error-p eof-value recursivep) - (let ((whitechar (read-char stream nil eof-object))) + (let ((whitechar (read-char stream nil *eof-object*))) (if (and (not (eofp whitechar)) (or (not (whitespacep whitechar)) recursivep)) @@ -549,7 +545,7 @@ ;;; -- The position of the first package delimiter (or NIL). (defun internal-read-extended-token (stream firstchar) (reset-read-buffer) - (do ((char firstchar (read-char stream nil eof-object)) + (do ((char firstchar (read-char stream nil *eof-object*)) (escapes ()) (colon nil)) ((cond ((eofp char) t) @@ -562,7 +558,7 @@ ;; It can't be a number, even if it's 1\23. ;; Read next char here, so it won't be casified. (push *ouch-ptr* escapes) - (let ((nextchar (read-char stream nil eof-object))) + (let ((nextchar (read-char stream nil *eof-object*))) (if (eofp nextchar) (reader-eof-error stream "after escape character") (ouch-read-buffer nextchar)))) @@ -570,13 +566,13 @@ ;; Read to next multiple-escape, escaping single chars along the ;; way. (loop - (let ((ch (read-char stream nil eof-object))) + (let ((ch (read-char stream nil *eof-object*))) (cond ((eofp ch) (reader-eof-error stream "inside extended token")) ((multiple-escape-p ch) (return)) ((escapep ch) - (let ((nextchar (read-char stream nil eof-object))) + (let ((nextchar (read-char stream nil *eof-object*))) (if (eofp nextchar) (reader-eof-error stream "after escape character") (ouch-read-buffer nextchar)))) @@ -1303,8 +1299,8 @@ (let ((numargp nil) (numarg 0) (sub-char ())) - (do* ((ch (read-char stream nil eof-object) - (read-char stream nil eof-object)) + (do* ((ch (read-char stream nil *eof-object*) + (read-char stream nil *eof-object*)) (dig ())) ((or (eofp ch) (not (setq dig (digit-char-p ch)))) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 7658e80..71dedbc 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -19,10 +19,9 @@ (options sb-c-call:int) (rusage sb-c-call:int)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant wait-wnohang #-svr4 1 #+svr4 #o100) - (defconstant wait-wuntraced #-svr4 2 #+svr4 4) - (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced)) +(defconstant wait-wnohang #-svr4 1 #+svr4 #o100) +(defconstant wait-wuntraced #-svr4 2 #+svr4 4) +(defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced) (defun wait3 (&optional do-not-hang check-for-stopped) "Return any available status information on child process. " diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index 3ceba16..5bf53d8 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -35,15 +35,8 @@ "VARIABLE must evaluate to a symbol. This symbol's special value cell is set to the specified new value." (declare (type symbol variable)) - (cond ((null variable) - (error "Nihil ex nihil, NIL can't be set.")) - ((eq variable t) - (error "Veritas aeterna, T can't be set.")) - ((and (boundp '*keyword-package*) - (keywordp variable)) - (error "Keywords can't be set.")) - (t - (%set-symbol-value variable new-value)))) + (about-to-modify variable) + (%set-symbol-value variable new-value)) (defun %set-symbol-value (symbol new-value) (%set-symbol-value symbol new-value)) @@ -200,6 +193,7 @@ (setf (symbol-function new-symbol) (symbol-function symbol)))) new-symbol) +;;; FIXME: This declaration should be redundant. (declaim (special *keyword-package*)) (defun keywordp (object) diff --git a/src/code/target-eval.lisp b/src/code/target-eval.lisp index 0baf841..8345ec7 100644 --- a/src/code/target-eval.lisp +++ b/src/code/target-eval.lisp @@ -93,13 +93,14 @@ ;;;; EVAL and friends -;;; This needs to be initialized in the cold load, since the top-level catcher -;;; will always restore the initial value. +;;; This needs to be initialized in the cold load, since the top-level +;;; catcher will always restore the initial value. (defvar *eval-stack-top* 0) ;;; Pick off a few easy cases, and call INTERNAL-EVAL for the rest. If -;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing a call -;;; so that the effect is confined to the lexical scope of the EVAL-WHEN. +;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing +;;; a call so that the effect is confined to the lexical scope of the +;;; EVAL-WHEN. (defun eval (original-exp) #!+sb-doc "Evaluates its single arg in a null lexical environment, returns the @@ -140,8 +141,8 @@ ((null name) (do ((args (cdr exp) (cddr args))) ((null (cddr args)) - ;; We duplicate the call to SET so that the correct - ;; value gets returned. + ;; We duplicate the call to SET so that the + ;; correct value gets returned. (set (first args) (eval (second args)))) (set (first args) (eval (second args))))) (let ((symbol (first name))) diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 1ed89b0..e362550 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -317,54 +317,50 @@ (format-print-ordinal stream (next-arg)) (format-print-cardinal stream (next-arg)))))) -(defconstant cardinal-ones +(defparameter *cardinal-ones* #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) -(defconstant cardinal-tens +(defparameter *cardinal-tens* #(nil nil "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")) -(defconstant cardinal-teens +(defparameter *cardinal-teens* #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) -(defconstant cardinal-periods +(defparameter *cardinal-periods* #("" " thousand" " million" " billion" " trillion" " quadrillion" " quintillion" " sextillion" " septillion" " octillion" " nonillion" " decillion" " undecillion" " duodecillion" " tredecillion" " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" " octodecillion" " novemdecillion" " vigintillion")) -(defconstant ordinal-ones +(defparameter *ordinal-ones* #(nil "first" "second" "third" "fourth" - "fifth" "sixth" "seventh" "eighth" "ninth") - #!+sb-doc - "Table of ordinal ones-place digits in English") + "fifth" "sixth" "seventh" "eighth" "ninth")) -(defconstant ordinal-tens +(defparameter *ordinal-tens* #(nil "tenth" "twentieth" "thirtieth" "fortieth" - "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth") - #!+sb-doc - "Table of ordinal tens-place digits in English") + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) (defun format-print-small-cardinal (stream n) (multiple-value-bind (hundreds rem) (truncate n 100) (when (plusp hundreds) - (write-string (svref cardinal-ones hundreds) stream) + (write-string (svref *cardinal-ones* hundreds) stream) (write-string " hundred" stream) (when (plusp rem) (write-char #\space stream))) (when (plusp rem) (multiple-value-bind (tens ones) (truncate rem 10) (cond ((< 1 tens) - (write-string (svref cardinal-tens tens) stream) + (write-string (svref *cardinal-tens* tens) stream) (when (plusp ones) (write-char #\- stream) - (write-string (svref cardinal-ones ones) stream))) + (write-string (svref *cardinal-ones* ones) stream))) ((= tens 1) - (write-string (svref cardinal-teens ones) stream)) + (write-string (svref *cardinal-teens* ones) stream)) ((plusp ones) - (write-string (svref cardinal-ones ones) stream))))))) + (write-string (svref *cardinal-ones* ones) stream))))))) (defun format-print-cardinal (stream n) (cond ((minusp n) @@ -385,7 +381,7 @@ (unless (zerop beyond) (write-char #\space stream)) (format-print-small-cardinal stream here) - (write-string (svref cardinal-periods period) stream)))) + (write-string (svref *cardinal-periods* period) stream)))) (defun format-print-ordinal (stream n) (when (minusp n) @@ -399,16 +395,16 @@ (multiple-value-bind (tens ones) (truncate bot 10) (cond ((= bot 12) (write-string "twelfth" stream)) ((= tens 1) - (write-string (svref cardinal-teens ones) stream);;;RAD + (write-string (svref *cardinal-teens* ones) stream);;;RAD (write-string "th" stream)) ((and (zerop tens) (plusp ones)) - (write-string (svref ordinal-ones ones) stream)) + (write-string (svref *ordinal-ones* ones) stream)) ((and (zerop ones)(plusp tens)) - (write-string (svref ordinal-tens tens) stream)) + (write-string (svref *ordinal-tens* tens) stream)) ((plusp bot) - (write-string (svref cardinal-tens tens) stream) + (write-string (svref *cardinal-tens* tens) stream) (write-char #\- stream) - (write-string (svref ordinal-ones ones) stream)) + (write-string (svref *ordinal-ones* ones) stream)) ((plusp number) (write-string "th" stream)) (t diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index ed6d7fe..dea5d2c 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -14,8 +14,7 @@ ;;;; utilities -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant max-hash most-positive-fixnum)) +(defconstant max-hash most-positive-fixnum) (deftype hash () `(integer 0 ,max-hash)) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index dfa628e..f015581 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -38,17 +38,12 @@ ;;;; SLOLOAD -;;; something not EQ to anything read from a file -;;; FIXME: shouldn't be DEFCONSTANT; and maybe make a shared EOF cookie in -;;; SB-INT:*EOF-VALUE*? -(defconstant load-eof-value '(())) - ;;; Load a text file. (defun sloload (stream verbose print) (do-load-verbose stream verbose) - (do ((sexpr (read stream nil load-eof-value) - (read stream nil load-eof-value))) - ((eq sexpr load-eof-value) + (do ((sexpr (read stream nil *eof-object*) + (read stream nil *eof-object*))) + ((eq sexpr *eof-object*) t) (if print (let ((results (multiple-value-list (eval sexpr)))) diff --git a/src/code/target-numbers.lisp b/src/code/target-numbers.lisp index 047282d..c518c6a 100644 --- a/src/code/target-numbers.lisp +++ b/src/code/target-numbers.lisp @@ -45,17 +45,16 @@ (frob var type)) (frob var type))))))) -;;; Our guess for the preferred order to do type tests in (cheaper and/or more -;;; probable first.) -;;; FIXME: not an EQL thing, should not be DEFCONSTANT -(defconstant type-test-ordering +;;; our guess for the preferred order in which to do type tests +;;; (cheaper and/or more probable first.) +(defparameter *type-test-ordering* '(fixnum single-float double-float integer #!+long-float long-float bignum complex ratio)) -;;; Return true if Type1 should be tested before Type2. +;;; Should TYPE1 be tested before TYPE2? (defun type-test-order (type1 type2) - (let ((o1 (position type1 type-test-ordering)) - (o2 (position type2 type-test-ordering))) + (let ((o1 (position type1 *type-test-ordering*)) + (o2 (position type2 *type-test-ordering*))) (cond ((not o1) nil) ((not o2) t) (t diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index c4aa06e..baa3ef8 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -967,23 +967,30 @@ ;; Put shadowing symbols in the shadowing symbols list. (setf (package-%shadowing-symbols pkg) (sixth spec)))) + ;; FIXME: These assignments are also done at toplevel in + ;; boot-extensions.lisp. They should probably only be done once. + (/show0 "setting up *CL-PACKAGE* and *KEYWORD-PACKAGE*") + (setq *cl-package* (find-package "COMMON-LISP")) + (setq *keyword-package* (find-package "KEYWORD")) + (/show0 "about to MAKUNBOUND *!INITIAL-SYMBOLS*") (makunbound '*!initial-symbols*) ; (so that it gets GCed) - ;; Make some other packages that should be around in the cold load. The - ;; COMMON-LISP-USER package is required by the ANSI standard, but not - ;; completely specified by it, so in the cross-compilation host Lisp it could - ;; contain various symbols, USE-PACKAGEs, or nicknames that we don't want in - ;; our target SBCL. For that reason, we handle it specially, not dumping the - ;; host Lisp version at genesis time.. + ;; Make some other packages that should be around in the cold load. + ;; The COMMON-LISP-USER package is required by the ANSI standard, + ;; but not completely specified by it, so in the cross-compilation + ;; host Lisp it could contain various symbols, USE-PACKAGEs, or + ;; nicknames that we don't want in our target SBCL. For that reason, + ;; we handle it specially, not dumping the host Lisp version at + ;; genesis time.. (assert (not (find-package "COMMON-LISP-USER"))) ;; ..but instead making our own from scratch here. (/show0 "about to MAKE-PACKAGE COMMON-LISP-USER") (make-package "COMMON-LISP-USER" :nicknames '("CL-USER") :use '("COMMON-LISP" - ;; ANSI encourages us to put extension packages in the - ;; USE list of COMMON-LISP-USER. + ;; ANSI encourages us to put extension packages + ;; in the USE list of COMMON-LISP-USER. "SB!ALIEN" "SB!C-CALL" "SB!DEBUG" "SB!EXT" "SB!GRAY" "SB!PROFILE")) @@ -996,16 +1003,11 @@ (/show0 "about to SETQ *IN-PACKAGE-INIT*") (setq *in-package-init* nil) - ;; FIXME: These assignments are also done at toplevel in - ;; boot-extensions.lisp. They should probably only be done once. - (setq *cl-package* (find-package "COMMON-LISP")) - (setq *keyword-package* (find-package "KEYWORD")) - ;; For the kernel core image wizards, set the package to *CL-PACKAGE*. ;; - ;; FIXME: We should just set this to (FIND-PACKAGE "COMMON-LISP-USER") - ;; once and for all here, instead of setting it once here and resetting - ;; it later. + ;; FIXME: We should just set this to (FIND-PACKAGE + ;; "COMMON-LISP-USER") once and for all here, instead of setting it + ;; once here and resetting it later. (setq *package* *cl-package*)) (!cold-init-forms diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index 1756f7c..e82f7a0 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -57,9 +57,9 @@ (defun make-random-state (&optional state) #!+sb-doc - "Make a random state object. If State is not supplied, return a copy - of the default random state. If State is a random state, then return a - copy of it. If state is T then return a random state generated from + "Make a random state object. If STATE is not supplied, return a copy + of the default random state. If STATE is a random state, then return a + copy of it. If STATE is T then return a random state generated from the universal time." (flet ((copy-random-state (state) (let ((state (random-state-state state)) diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index d6bba00..318e21b 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -17,9 +17,7 @@ ;;; depth and what Common Lisp ordinarily calls length; it's incremented either ;;; when we descend into a compound object or when we step through elements of ;;; a compound object. -(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +max-hash-depthoid+ 4) -) ; EVAL-WHEN ;;;; mixing hash values diff --git a/src/code/time.lisp b/src/code/time.lisp index c808845..4f72454 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -99,9 +99,9 @@ (minutes-west sb!c-call:int :out) (daylight-savings-p sb!alien:boolean :out)) -;;; Subtract from the returned Internal-Time to get the universal time. -;;; The offset between our time base and the Perq one is 2145 weeks and -;;; five days. +;;; Subtract from the returned Internal-Time to get the universal +;;; time. The offset between our time base and the Perq one is 2145 +;;; weeks and five days. (defconstant seconds-in-week (* 60 60 24 7)) (defconstant weeks-offset 2145) (defconstant seconds-offset 432000) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index 360a4e8..df1512c 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -119,9 +119,9 @@ :complex-= (type-class-complex-= x) :unparse (type-class-unparse x))) -;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have to -;;; be tweaked to match. -- WHN 19991021 -(defconstant type-class-function-slots +;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here +;;; will have to be tweaked to match. -- WHN 19991021 +(defparameter *type-class-function-slots* '((:simple-subtypep . type-class-simple-subtypep) (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1) (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2) @@ -134,7 +134,7 @@ (:unparse . type-class-unparse))) (defun class-function-slot-or-lose (name) - (or (cdr (assoc name type-class-function-slots)) + (or (cdr (assoc name *type-class-function-slots*)) (error "~S is not a defined type class method." name))) ;;; FIXME: This seems to be called at runtime by cold init code. ;;; Make sure that it's not being called at runtime anywhere but diff --git a/src/code/uncross.lisp b/src/code/uncross.lisp index 8043676..68d6e00 100644 --- a/src/code/uncross.lisp +++ b/src/code/uncross.lisp @@ -37,29 +37,32 @@ (uncross-rcr-failure-form c))))) |# -;;; When cross-compiling, EVAL-WHEN :COMPILE-TOPLEVEL code is executed in the -;;; host Common Lisp, not the target. A certain amount of dancing around is -;;; required in order for this to work more or less correctly. (Fortunately, -;;; more or less correctly is good enough -- it only needs to work on the -;;; EVAL-WHEN expressions found in the SBCL sources themselves, and we can -;;; exercise self-control to keep them from including anything which too -;;; strongly resembles a language lawyer's test case.) +;;; When cross-compiling, EVAL-WHEN :COMPILE-TOPLEVEL code is executed +;;; in the host Common Lisp, not the target. A certain amount of +;;; dancing around is required in order for this to work more or less +;;; correctly. (Fortunately, more or less correctly is good enough -- +;;; it only needs to work on the EVAL-WHEN expressions found in the +;;; SBCL sources themselves, and we can exercise self-control to keep +;;; them from including anything which too strongly resembles a +;;; language lawyer's test case.) ;;; -;;; In order to make the dancing happen, we need to make a distinction between -;;; SB!XC and COMMON-LISP when we're executing a form at compile time (i.e. -;;; within EVAL-WHEN :COMPILE-TOPLEVEL) but we need to treat SB!XC as -;;; synonymous with COMMON-LISP otherwise. This can't be done by making SB!XC a -;;; nickname of COMMON-LISP, because the reader processes things before -;;; EVAL-WHEN, so by the time EVAL-WHEN :COMPILE-TOPLEVEL saw a form, the -;;; distinction it needs would be lost. Instead, we read forms preserving this -;;; distinction (treating SB!XC as a separate package), and only when we're -;;; about to process them (for any situation other than -;;; EVAL-WHEN (:COMPILE-TOPLEVEL)) do we call UNCROSS on them to obliterate the +;;; In order to make the dancing happen, we need to make a distinction +;;; between SB!XC and COMMON-LISP when we're executing a form at +;;; compile time (i.e. within EVAL-WHEN :COMPILE-TOPLEVEL) but we need +;;; to treat SB!XC as synonymous with COMMON-LISP otherwise. This +;;; can't be done by making SB!XC a nickname of COMMON-LISP, because +;;; the reader processes things before EVAL-WHEN, so by the time +;;; EVAL-WHEN :COMPILE-TOPLEVEL saw a form, the distinction it needs +;;; would be lost. Instead, we read forms preserving this distinction +;;; (treating SB!XC as a separate package), and only when we're about +;;; to process them (for any situation other than EVAL-WHEN +;;; (:COMPILE-TOPLEVEL)) do we call UNCROSS on them to obliterate the ;;; distinction. #+sb-xc-host (defun uncross (form) (let ((;; KLUDGE: We don't currently try to handle circular program - ;; structure, but we do at least detect it and complain about it.. + ;; structure, but we do at least detect it and complain about + ;; it.. inside? (make-hash-table))) (labels ((uncross-symbol (symbol) (let ((old-symbol-package (symbol-package symbol))) @@ -67,7 +70,7 @@ (string= (package-name old-symbol-package) "SB-XC")) (values (intern (symbol-name symbol) "COMMON-LISP")) symbol))) - (rcr (form) + (rcr (form) ; recursive part (cond ((symbolp form) (uncross-symbol form)) ((or (numberp form) @@ -75,44 +78,35 @@ (stringp form)) form) (t - ;; If we reach here, FORM is something with internal - ;; structure which could include symbols in the SB-XC - ;; package. + ;; If we reach here, FORM is something with + ;; internal structure which could include + ;; symbols in the SB-XC package. (when (gethash form inside?) (let ((*print-circle* t)) - ;; This code could probably be generalized to work on - ;; circular structure, but it seems easier just to - ;; avoid putting any circular structure into the - ;; bootstrap code. + ;; This code could probably be generalized + ;; to work on circular structure, but it + ;; seems easier just to avoid putting any + ;; circular structure into the bootstrap + ;; code. (error "circular structure in ~S" form))) (setf (gethash form inside?) t) (unwind-protect (typecase form (cons (rcr-cons form)) - ;; Note: This function was originally intended to - ;; search through structures other than CONS, but - ;; it got into trouble with LAYOUT-CLASS and - ;; CLASS-LAYOUT circular structure. After some - ;; messing around, it turned out that recursing - ;; through CONS is all that's needed in practice.) - ;; FIXME: This leaves a lot of stale code here - ;; (already commented/NILed out) for us to delete. - #+nil ; only searching through CONS - (simple-vector (rcr-simple-vector form)) - #+nil ; only searching through CONS - (structure!object - (rcr-structure!object form)) (t - ;; KLUDGE: I know that UNCROSS is far from - ;; perfect, but it's good enough to cross-compile - ;; the current sources, and getting hundreds of - ;; warnings about individual cases it can't - ;; recurse through, so the warning here has been - ;; turned off. Eventually it would be nice either - ;; to set up a cleaner way of cross-compiling - ;; which didn't have this problem, or to make - ;; an industrial-strength version of UNCROSS - ;; which didn't fail this way. -- WHN 20000201 + ;; KLUDGE: There are other types + ;; (especially (ARRAY T) and + ;; STRUCTURE-OBJECT, but also HASH-TABLE + ;; and perhaps others) which could hold + ;; symbols. In principle we should handle + ;; those types as well. Failing that, we + ;; could give warnings for them. However, + ;; the current system works for + ;; bootstrapping in practice (because we + ;; don't use those constructs that way) + ;; and the warnings more annoying than + ;; useful, so I simply turned the + ;; warnings off. -- WHN 20001105 #+nil (warn 'uncross-rcr-failure :form form) form)) (remhash form inside?))))) @@ -124,41 +118,5 @@ (rcr-cdr (rcr cdr))) (if (and (eq rcr-car car) (eq rcr-cdr cdr)) form - (cons rcr-car rcr-cdr)))) - #+nil ; only searching through CONS in this version - (rcr-simple-vector (form) - (declare (type simple-vector form)) - (dotimes (i (length form)) - (let* ((aref (aref form i)) - (rcr-aref (rcr aref))) - (unless (eq rcr-aref aref) - (return (map 'vector #'rcr form)))) - form)) - #+nil ; only searching through CONS in this version - (rcr-structure!object (form) - (declare (type structure!object form)) - ;; Note: We skip the zeroth slot because it's used for LAYOUT, - ;; which shouldn't require any translation and which is - ;; complicated to think about anyway. - (do ((i 1 (1+ i))) - ((>= i (%instance-length form)) form) - (let* ((instance-ref (%instance-ref form i)) - (rcr-instance-ref (rcr instance-ref))) - (unless (eq rcr-instance-ref instance-ref) - (return (rcr!-structure!object - (copy-structure form))))))) - #+nil ; only searching through CONS in this version - (rcr!-structure!object (form) - (declare (type structure!object form)) - ;; As in RCR-STRUCTURE!OBJECT, we skip the zeroth slot. - (do ((i 1 (1+ i))) - ((>= i (%instance-length form))) - (let* ((instance-ref (%instance-ref form i)) - (rcr-instance-ref (rcr instance-ref))) - ;; (By only calling SETF when strictly necessary, - ;; we avoid bombing out unnecessarily when the - ;; I-th slot happens to be read-only.) - (unless (eq rcr-instance-ref instance-ref) - (setf (%instance-ref form i) - rcr-instance-ref)))))) + (cons rcr-car rcr-cdr))))) (rcr form)))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index c6083a6..cb64f81 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -36,10 +36,9 @@ (sb!xc:defmacro def-unix-error (name number description) `(progn + (defconstant ,name ,number ,description) (eval-when (:compile-toplevel :execute) - (push (cons ,number ,description) *compiler-unix-errors*)) - (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,name ,number ,description)))) + (push (cons ,number ,description) *compiler-unix-errors*)))) (sb!xc:defmacro emit-unix-errors () (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*))) @@ -193,9 +192,8 @@ #!+linux long #!+bsd quad-t) -(eval-when (:compile-toplevel :load-toplevel :execute) - (/show0 "unix.lisp 215") - (defconstant fd-setsize 1024)) +(/show0 "unix.lisp 195") +(defconstant fd-setsize 1024) (/show0 "unix.lisp 217") (def-alien-type nil @@ -328,7 +326,6 @@ (void-syscall ("close" int) fd)) ;;; fcntlbits.h -(eval-when (:compile-toplevel :load-toplevel :execute) (/show0 "unix.lisp 337") (defconstant o_rdonly 0) ; read-only flag @@ -352,7 +349,6 @@ #!+linux #o2000 #!+bsd #x0008) (/show0 "unix.lisp 361") -) ; EVAL-WHEN ;;;; timebits.h diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index a21399b..9b1a80f 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -409,7 +409,7 @@ ((:maybe) (give-up-ir1-transform "The array type is ambiguous; must call ~ - array-has-fill-pointer-p at runtime."))))))) + ARRAY-HAS-FILL-POINTER-P at runtime."))))))) ;;; Primitive used to verify indices into arrays. If we can tell at ;;; compile-time or we are generating unsafe code, don't bother with diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index eb718e5..644b6df 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -853,29 +853,31 @@ (defvar *byte-component-info*) -(eval-when (#+sb-xc :compile-toplevel :load-toplevel :execute) - (defconstant byte-push-local #b00000000) - (defconstant byte-push-arg #b00010000) - (defconstant byte-push-constant #b00100000) - (defconstant byte-push-system-constant #b00110000) - (defconstant byte-push-int #b01000000) - (defconstant byte-push-neg-int #b01010000) - (defconstant byte-pop-local #b01100000) - (defconstant byte-pop-n #b01110000) - (defconstant byte-call #b10000000) - (defconstant byte-tail-call #b10010000) - (defconstant byte-multiple-call #b10100000) - (defconstant byte-named #b00001000) - (defconstant byte-local-call #b10110000) - (defconstant byte-local-tail-call #b10111000) - (defconstant byte-local-multiple-call #b11000000) - (defconstant byte-return #b11001000) - (defconstant byte-branch-always #b11010000) - (defconstant byte-branch-if-true #b11010010) - (defconstant byte-branch-if-false #b11010100) - (defconstant byte-branch-if-eq #b11010110) - (defconstant byte-xop #b11011000) - (defconstant byte-inline-function #b11100000)) +;;; FIXME: These might as well be generated with DEFENUM, right? +;;; It would also be nice to give them less ambiguous names, perhaps +;;; with a "BYTEOP-" prefix instead of "BYTE-". +(defconstant byte-push-local #b00000000) +(defconstant byte-push-arg #b00010000) +(defconstant byte-push-constant #b00100000) +(defconstant byte-push-system-constant #b00110000) +(defconstant byte-push-int #b01000000) +(defconstant byte-push-neg-int #b01010000) +(defconstant byte-pop-local #b01100000) +(defconstant byte-pop-n #b01110000) +(defconstant byte-call #b10000000) +(defconstant byte-tail-call #b10010000) +(defconstant byte-multiple-call #b10100000) +(defconstant byte-named #b00001000) +(defconstant byte-local-call #b10110000) +(defconstant byte-local-tail-call #b10111000) +(defconstant byte-local-multiple-call #b11000000) +(defconstant byte-return #b11001000) +(defconstant byte-branch-always #b11010000) +(defconstant byte-branch-if-true #b11010010) +(defconstant byte-branch-if-false #b11010100) +(defconstant byte-branch-if-eq #b11010110) +(defconstant byte-xop #b11011000) +(defconstant byte-inline-function #b11100000) (defun output-push-int (segment int) (declare (type sb!assem:segment segment) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 07cf51d..e36ec9b 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -22,8 +22,8 @@ '(member :unknown-return :known-return :internal-error :non-local-exit :block-start :call-site :single-value-return :non-local-entry)) -;;; The Location-Info structure holds the information what we need about -;;; locations which code generation decided were "interesting". +;;; The LOCATION-INFO structure holds the information what we need +;;; about locations which code generation decided were "interesting". (defstruct (location-info (:constructor make-location-info (kind label vop))) ;; The kind of location noted. @@ -33,9 +33,9 @@ ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.) (vop nil :type vop)) -;;; Called during code generation in places where there is an "interesting" -;;; location: some place where we are likely to end up in the debugger, and -;;; thus want debug info. +;;; This is called during code generation in places where there is an +;;; "interesting" location: someplace where we are likely to end up +;;; in the debugger, and thus want debug info. (defun note-debug-location (vop label kind) (declare (type vop vop) (type (or label null) label) (type location-kind kind)) @@ -50,10 +50,11 @@ (declare (type ir2-block 2block)) (block-environment (ir2-block-block 2block))) -;;; Given a local conflicts vector and an IR2 block to represent the set of -;;; live TNs, and the Var-Locs hash-table representing the variables dumped, -;;; compute a bit-vector representing the set of live variables. If the TN is -;;; environment-live, we only mark it as live when it is in scope at Node. +;;; Given a local conflicts vector and an IR2 block to represent the +;;; set of live TNs, and the VAR-LOCS hash-table representing the +;;; variables dumped, compute a bit-vector representing the set of +;;; live variables. If the TN is environment-live, we only mark it as +;;; live when it is in scope at NODE. (defun compute-live-vars (live node block var-locs vop) (declare (type ir2-block block) (type local-tn-bit-vector live) (type hash-table var-locs) (type node node) @@ -81,9 +82,10 @@ (defvar *previous-location*) (declaim (type index *previous-location*)) -;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the -;;; code/source map and live info. If true, VOP is the VOP associated with -;;; this location, for use in determining whether TNs are spilled. +;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes +;;; the code/source map and live info. If true, VOP is the VOP +;;; associated with this location, for use in determining whether TNs +;;; are spilled. (defun dump-1-location (node block kind tlf-num label live var-locs vop) (declare (type node node) (type ir2-block block) (type local-tn-bit-vector live) @@ -92,7 +94,7 @@ (type hash-table var-locs) (type (or vop null) vop)) (vector-push-extend - (dpb (position-or-lose kind compiled-code-location-kinds) + (dpb (position-or-lose kind *compiled-code-location-kinds*) compiled-code-location-kind-byte 0) *byte-buffer*) @@ -111,8 +113,8 @@ (values)) -;;; Extract context info from a Location-Info structure and use it to dump a -;;; compiled code-location. +;;; Extract context info from a Location-Info structure and use it to +;;; dump a compiled code-location. (defun dump-location-from-info (loc tlf-num var-locs) (declare (type location-info loc) (type (or index null) tlf-num) (type hash-table var-locs)) @@ -127,8 +129,8 @@ vop)) (values)) -;;; Scan all the blocks, determining if all locations are in the same TLF, -;;; and returning it or NIL. +;;; Scan all the blocks, determining if all locations are in the same +;;; TLF, and returning it or NIL. (defun find-tlf-number (fun) (declare (type clambda fun)) (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))) @@ -194,13 +196,13 @@ *byte-buffer*)))) (values)) -;;; Return a vector and an integer (or null) suitable for use as the BLOCKS -;;; and TLF-NUMBER in Fun's debug-function. This requires two passes to -;;; compute: -;;; -- Scan all blocks, dumping the header and successors followed by all the -;;; non-elsewhere locations. -;;; -- Dump the elsewhere block header and all the elsewhere locations (if -;;; any.) +;;; Return a vector and an integer (or null) suitable for use as the +;;; BLOCKS and TLF-NUMBER in Fun's debug-function. This requires two +;;; passes to compute: +;;; -- Scan all blocks, dumping the header and successors followed +;;; by all the non-elsewhere locations. +;;; -- Dump the elsewhere block header and all the elsewhere +;;; locations (if any.) (defun compute-debug-blocks (fun var-locs) (declare (type clambda fun) (type hash-table var-locs)) (setf (fill-pointer *byte-buffer*) 0) @@ -235,10 +237,10 @@ (values (copy-seq *byte-buffer*) tlf-num))) -;;; Return a list of DEBUG-SOURCE structures containing information derived -;;; from Info. Unless :BYTE-COMPILE T was specified, we always dump the -;;; Start-Positions, since it is too hard figure out whether we need them or -;;; not. +;;; Return a list of DEBUG-SOURCE structures containing information +;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always +;;; dump the Start-Positions, since it is too hard figure out whether +;;; we need them or not. (defun debug-source-for-info (info) (declare (type source-info info)) (assert (not (source-info-current-file info))) @@ -271,17 +273,18 @@ (source-info-files info))) ;;; Given an arbitrary sequence, coerce it to an unsigned vector if -;;; possible. Ordinarily we coerce it to the smallest specialized vector -;;; we can. However, we also have a special hack for cross-compiling at -;;; bootstrap time, when arbitrarily-specialized aren't fully supported: -;;; in that case, we coerce it only to a vector whose element size is an -;;; integer multiple of output byte size. +;;; possible. Ordinarily we coerce it to the smallest specialized +;;; vector we can. However, we also have a special hack for +;;; cross-compiling at bootstrap time, when arbitrarily-specialized +;;; aren't fully supported: in that case, we coerce it only to a +;;; vector whose element size is an integer multiple of output byte +;;; size. (defun coerce-to-smallest-eltype (seq) (let ((maxoid #-sb-xc-host 0 - ;; An initial value value of 255 prevents us from specializing - ;; the array to anything smaller than (UNSIGNED-BYTE 8), which - ;; keeps the cross-compiler's portable specialized array output - ;; functions happy. + ;; An initial value value of 255 prevents us from + ;; specializing the array to anything smaller than + ;; (UNSIGNED-BYTE 8), which keeps the cross-compiler's + ;; portable specialized array output functions happy. #+sb-xc-host 255)) (flet ((frob (x) (if (typep x 'unsigned-byte) @@ -304,15 +307,15 @@ (make-sc-offset (sc-number (tn-sc tn)) (tn-offset tn))) -;;; Dump info to represent Var's location being TN. ID is an integer that -;;; makes Var's name unique in the function. Buffer is the vector we stick the -;;; result in. If Minimal is true, we suppress name dumping, and set the -;;; minimal flag. +;;; Dump info to represent Var's location being TN. ID is an integer +;;; that makes Var's name unique in the function. Buffer is the vector +;;; we stick the result in. If Minimal is true, we suppress name +;;; dumping, and set the minimal flag. ;;; ;;; The debug-var is only marked as always-live if the TN is -;;; environment live and is an argument. If a :debug-environment TN, then we -;;; also exclude set variables, since the variable is not guaranteed to be live -;;; everywhere in that case. +;;; environment live and is an argument. If a :debug-environment TN, +;;; then we also exclude set variables, since the variable is not +;;; guaranteed to be live everywhere in that case. (defun dump-1-variable (fun var tn id minimal buffer) (declare (type lambda-var var) (type (or tn null) tn) (type index id) (type clambda fun)) @@ -348,10 +351,11 @@ (vector-push-extend (tn-sc-offset save-tn) buffer))) (values)) -;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of FUN. -;;; LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a hashtable in which -;;; we enter the translation from LAMBDA-VARS to the relative position of that -;;; variable's location in the resulting vector. +;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES +;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a +;;; hashtable in which we enter the translation from LAMBDA-VARS to +;;; the relative position of that variable's location in the resulting +;;; vector. (defun compute-variables (fun level var-locs) (declare (type clambda fun) (type hash-table var-locs)) (collect ((vars)) @@ -405,7 +409,7 @@ (coerce buffer 'simple-vector))) ;;; Return Var's relative position in the function's variables (determined -;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED. +;;; from the Var-Locs hashtable.) If Var is deleted, then return DELETED. (defun debug-location-for (var var-locs) (declare (type lambda-var var) (type hash-table var-locs)) (let ((res (gethash var var-locs))) @@ -417,12 +421,13 @@ ;;;; arguments/returns -;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for -;;; Fun. If fun is the MAIN-ENTRY for an optional dispatch, then look at the -;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed. +;;; Return a vector to be used as the +;;; COMPILED-DEBUG-FUNCTION-ARGUMENTS for Fun. If fun is the +;;; MAIN-ENTRY for an optional dispatch, then look at the ARGLIST to +;;; determine the syntax, otherwise pretend all arguments are fixed. ;;; -;;; ### This assumption breaks down in EPs other than the main-entry, since -;;; they may or may not have supplied-p vars, etc. +;;; ### This assumption breaks down in EPs other than the main-entry, +;;; since they may or may not have supplied-p vars, etc. (defun compute-arguments (fun var-locs) (declare (type clambda fun) (type hash-table var-locs)) (collect ((res)) @@ -456,8 +461,8 @@ (coerce-to-smallest-eltype (res)))) -;;; Return a vector of SC offsets describing Fun's return locations. (Must -;;; be known values return...) +;;; Return a vector of SC offsets describing Fun's return locations. +;;; (Must be known values return...) (defun compute-debug-returns (fun) (coerce-to-smallest-eltype (mapcar #'(lambda (loc) @@ -488,8 +493,9 @@ :start-pc (label-position (ir2-environment-environment-start 2env)) :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env))))) -;;; Return a complete C-D-F structure for Fun. This involves determining -;;; the DEBUG-INFO level and filling in optional slots as appropriate. +;;; Return a complete C-D-F structure for Fun. This involves +;;; determining the DEBUG-INFO level and filling in optional slots as +;;; appropriate. (defun compute-1-debug-function (fun var-locs) (declare (type clambda fun) (type hash-table var-locs)) (let* ((dfun (dfun-from-fun fun)) @@ -532,18 +538,18 @@ ;;;; minimal debug functions -;;; Return true if Dfun can be represented as a minimal debug function. -;;; Dfun is a cons ( . C-D-F). +;;; Return true if DFUN can be represented as a minimal debug +;;; function. DFUN is a cons ( . C-D-F). (defun debug-function-minimal-p (dfun) (declare (type cons dfun)) (let ((dfun (cdr dfun))) (and (member (compiled-debug-function-arguments dfun) '(:minimal nil)) (null (compiled-debug-function-blocks dfun))))) -;;; Dump a packed binary representation of a Dfun into *byte-buffer*. -;;; Prev-Start and Start are the byte offsets in the code where the previous -;;; function started and where this one starts. Prev-Elsewhere is the previous -;;; function's elsewhere PC. +;;; Dump a packed binary representation of a DFUN into *BYTE-BUFFER*. +;;; PREV-START and START are the byte offsets in the code where the +;;; previous function started and where this one starts. +;;; PREV-ELSEWHERE is the previous function's elsewhere PC. (defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere) (declare (type compiled-debug-function dfun) (type index prev-start start prev-elsewhere)) @@ -567,7 +573,7 @@ (setf (ldb minimal-debug-function-name-style-byte options) name-rep) (setf (ldb minimal-debug-function-kind-byte options) (position-or-lose (compiled-debug-function-kind dfun) - minimal-debug-function-kinds)) + *minimal-debug-function-kinds*)) (setf (ldb minimal-debug-function-returns-byte options) (etypecase (compiled-debug-function-returns dfun) ((member :standard) minimal-debug-function-returns-standard) @@ -617,8 +623,8 @@ prev-elsewhere) *byte-buffer*))) -;;; Return a byte-vector holding all the debug functions for a component in -;;; the packed binary minimal-debug-function format. +;;; Return a byte-vector holding all the debug functions for a +;;; component in the packed binary minimal-debug-function format. (defun compute-minimal-debug-functions (dfuns) (declare (list dfuns)) (setf (fill-pointer *byte-buffer*) 0) @@ -654,8 +660,9 @@ (declare (type component component)) (collect ((dfuns)) (let ((var-locs (make-hash-table :test 'eq)) - ;; FIXME: What is *BYTE-BUFFER* for? Has it become dead code now that - ;; we no longer use minimal-debug-function representation? + ;; FIXME: What is *BYTE-BUFFER* for? Has it become dead code + ;; now that we no longer use minimal-debug-function + ;; representation? (*byte-buffer* (make-array 10 :element-type '(unsigned-byte 8) :fill-pointer 0 @@ -668,19 +675,20 @@ (let* ((sorted (sort (dfuns) #'< :key #'car)) ;; FIXME: CMU CL had ;; (IF (EVERY #'DEBUG-FUNCTION-MINIMAL-P SORTED) - ;; (COMPUTE-MINIMAL-DEBUG-FUNCTIONS SORTED) - ;; (COMPUTE-DEBUG-FUNCTION-MAP SORTED)) - ;; here. We've gotten rid of the minimal-debug-function case in - ;; SBCL because the minimal representation couldn't be made to - ;; transform properly under package renaming. Now that that - ;; case is gone, a lot of code is dead, and once everything is - ;; known to work, the dead code should be deleted. + ;; (COMPUTE-MINIMAL-DEBUG-FUNCTIONS SORTED) + ;; (COMPUTE-DEBUG-FUNCTION-MAP SORTED)) + ;; here. We've gotten rid of the minimal-debug-function + ;; case in SBCL because the minimal representation + ;; couldn't be made to transform properly under package + ;; renaming. Now that that case is gone, a lot of code is + ;; dead, and once everything is known to work, the dead + ;; code should be deleted. (function-map (compute-debug-function-map sorted))) (make-compiled-debug-info :name (component-name component) :function-map function-map))))) -;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of BITS -;;; must be evenly divisible by eight. +;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of +;;; BITS must be evenly divisible by eight. (defun write-packed-bit-vector (bits byte-buffer) (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer)) (multiple-value-bind (initial step done) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index a8acaee..77f6e04 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -276,8 +276,8 @@ (sb!xc:lisp-implementation-version))) (dump-byte sb!c:*fasl-header-string-stop-char-code* res) - ;; Finish the header by outputting fasl file implementation and version in - ;; machine-readable form. + ;; Finish the header by outputting fasl file implementation and + ;; version in machine-readable form. (multiple-value-bind (implementation version) (if byte-p (values *backend-byte-order* diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index b8732f8..ce2701d 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -15,10 +15,11 @@ (in-package "SB!C") -;;; FIXME: shouldn't SB-C::&MORE be in this list? -(defconstant sb!xc:lambda-list-keywords +;;; FIXME: Shouldn't SB-C::&MORE be in this list? +(defconstant-eqx sb!xc:lambda-list-keywords '(&optional &rest &key &aux &body &whole &allow-other-keys &environment) #!+sb-doc + #'equal "symbols which are magical in a lambda list") ;;;; cross-compiler-only versions of CL special variables, so that we @@ -52,12 +53,13 @@ (brevity nil :type cookie-quality) (debug nil :type cookie-quality)) -;;; KLUDGE: This needs to be executable in cold init toplevel forms, earlier -;;; than the default copier closure created by DEFSTRUCT toplevel forms would -;;; be available, and earlier than LAYOUT-INFO is initialized (which is a -;;; prerequisite for COPY-STRUCTURE to work), so we define it explicitly using -;;; DEFUN, so that it can be installed by the cold loader, and using -;;; hand-written, hand-maintained slot-by-slot copy it doesn't need to call +;;; KLUDGE: This needs to be executable in cold init toplevel forms, +;;; earlier than the default copier closure created by DEFSTRUCT +;;; toplevel forms would be available, and earlier than LAYOUT-INFO is +;;; initialized (which is a prerequisite for COPY-STRUCTURE to work), +;;; so we define it explicitly using DEFUN, so that it can be +;;; installed by the cold loader, and using hand-written, +;;; hand-maintained slot-by-slot copy it doesn't need to call ;;; COPY-STRUCTURE. -- WHN 19991019 (defun copy-cookie (cookie) (make-cookie :speed (cookie-speed cookie) @@ -67,10 +69,11 @@ :brevity (cookie-brevity cookie) :debug (cookie-debug cookie))) -;;; *DEFAULT-COOKIE* holds the current global compiler policy information. -;;; Whenever the policy is changed, we copy the structure so that old uses will -;;; still get the old values. *DEFAULT-INTERFACE-COOKIE* holds any values -;;; specified by an OPTIMIZE-INTERFACE declaration. +;;; *DEFAULT-COOKIE* holds the current global compiler policy +;;; information. Whenever the policy is changed, we copy the structure +;;; so that old uses will still get the old values. +;;; *DEFAULT-INTERFACE-COOKIE* holds any values specified by an +;;; OPTIMIZE-INTERFACE declaration. ;;; ;;; FIXME: Why isn't COOKIE called POLICY? (declaim (type cookie *default-cookie* *default-interface-cookie*)) @@ -80,7 +83,7 @@ ;;; possible values for the INLINE-ness of a function. (deftype inlinep () '(member :inline :maybe-inline :notinline nil)) -(defconstant inlinep-translations +(defparameter *inlinep-translations* '((inline . :inline) (notinline . :notinline) (maybe-inline . :maybe-inline))) @@ -153,11 +156,11 @@ (declaim (ftype (function (symbol) (values)) note-lexical-binding)) (defun note-lexical-binding (symbol) (let ((name (symbol-name symbol))) - ;; This check is intended to protect us from getting silently burned when - ;; we define + ;; This check is intended to protect us from getting silently + ;; burned when we define ;; foo.lisp: - ;; (DEFVAR *FOO*) - ;; (DEFUN FOO (X) (1+ X *FOO*)) + ;; (DEFVAR *FOO* -3) + ;; (DEFUN FOO (X) (+ X *FOO*)) ;; bar.lisp: ;; (DEFUN BAR (X) ;; (LET ((*FOO* X)) @@ -165,6 +168,7 @@ ;; and then we happen to compile bar.lisp before foo.lisp. (when (and (char= #\* (aref name 0)) (char= #\* (aref name (1- (length name))))) + ;; FIXME: should be COMPILER-STYLE-WARNING? (style-warn "using the lexical binding of the symbol ~S, not the~@ dynamic binding, even though the symbol name follows the usual naming~@ convention (names like *FOO*) for special variables" symbol))) diff --git a/src/compiler/eval.lisp b/src/compiler/eval.lisp index 52cd591..94fa93b 100644 --- a/src/compiler/eval.lisp +++ b/src/compiler/eval.lisp @@ -574,9 +574,9 @@ ;;;; INTERNAL-EVAL ;;; Evaluate an arbitary form. We convert the form, then call internal -;;; apply on it. If *ALREADY-EVALED-THIS* is true, then we bind it to NIL -;;; around the apply to limit the inhibition to the lexical scope of the -;;; EVAL-WHEN. +;;; APPLY on it. If *ALREADY-EVALED-THIS* is true, then we bind it to +;;; NIL around the apply to limit the inhibition to the lexical scope +;;; of the EVAL-WHEN. (defun internal-eval (form &optional quietly) (let ((res (sb!c:compile-for-eval form quietly))) (if *already-evaled-this* diff --git a/src/compiler/generic/early-vm-macs.lisp b/src/compiler/generic/early-vm-macs.lisp deleted file mode 100644 index bf667b0..0000000 --- a/src/compiler/generic/early-vm-macs.lisp +++ /dev/null @@ -1,33 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!VM") - -(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) - &rest identifiers) - (let ((results nil) - (index 0) - (start (eval start)) - (step (eval step))) - (dolist (id identifiers) - (when id - (multiple-value-bind (root docs) - (if (consp id) - (values (car id) (cdr id)) - (values id nil)) - (push `(defconstant ,(intern (concatenate 'simple-string - (string prefix) - (string root) - (string suffix))) - ,(+ start (* step index)) - ,@docs) - results))) - (incf index)) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(nreverse results)))) diff --git a/src/compiler/generic/early-vm.lisp b/src/compiler/generic/early-vm.lisp index 10636b6..c5f8a94 100644 --- a/src/compiler/generic/early-vm.lisp +++ b/src/compiler/generic/early-vm.lisp @@ -9,8 +9,6 @@ (in-package "SB!VM") -(eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant lowtag-bits 3 #!+sb-doc "Number of bits at the low end of a pointer used for type information.") @@ -31,8 +29,6 @@ #!+sb-doc "Mask to extract the type from a header word.") -); eval-when - ;;; FIXME: Couldn't/shouldn't these be DEFCONSTANT instead of DEFPARAMETER? (defparameter *target-most-positive-fixnum* (1- (ash 1 29)) #!+sb-doc diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 89c51d8..355f417 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -44,7 +44,8 @@ ;;; ;;; 0: inherited from CMU CL ;;; 1: rearranged static symbols for sbcl-0.6.8 -(defconstant sbcl-core-version-integer 1) +;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support +(defconstant sbcl-core-version-integer 2) (defun round-up (number size) #!+sb-doc @@ -62,12 +63,11 @@ (defvar *read-only*) (defconstant read-only-space-id 3) -(eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant descriptor-low-bits 16 - "the number of bits in the low half of the descriptor") - (defconstant target-space-alignment (ash 1 descriptor-low-bits) - "the alignment requirement for spaces in the target. - Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")) +(defconstant descriptor-low-bits 16 + "the number of bits in the low half of the descriptor") +(defconstant target-space-alignment (ash 1 descriptor-low-bits) + "the alignment requirement for spaces in the target. + Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)") ;;; a GENESIS-time representation of a memory space (e.g. read-only space, ;;; dynamic space, or static space) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index ad74c20..6516587 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -18,9 +18,9 @@ (defconstant vector-data-bit-offset (* sb!vm:vector-data-offset sb!vm:word-bits)) -;;; We need to define these predicates, since the TYPEP source transform picks -;;; whichever predicate was defined last when there are multiple predicates for -;;; equivalent types. +;;; We need to define these predicates, since the TYPEP source +;;; transform picks whichever predicate was defined last when there +;;; are multiple predicates for equivalent types. (def-source-transform short-float-p (x) `(single-float-p ,x)) #!-long-float (def-source-transform long-float-p (x) `(double-float-p ,x)) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index b27deb3..ad7d732 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -85,26 +85,33 @@ ((sb!sys:positive-primep n) n))) -;;;; info classes, info types, and type numbers, part I: what's needed not only -;;;; at compile time but also at run time - -;;;; Note: This section is a blast from the past, a little trip down memory -;;;; lane to revisit the weird host/target interactions of the CMU CL build -;;;; process. Because of the way that the cross-compiler and target compiler -;;;; share stuff here, if you change anything in here, you'd be well-advised to -;;;; nuke all your fasl files and restart compilation from the very beginning -;;;; of the bootstrap process. - -;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're running -;;; the cross-compiler? The cross-compiler (which was built from these sources) -;;; has its version of these data and functions defined in the same places we'd -;;; be defining into. We're happy with its version, since it was compiled from -;;; the same sources, so there's no point in overwriting its nice compiled -;;; version of this stuff with our interpreted version. (And any time we're -;;; *not* happy with its version, perhaps because we've been editing the -;;; sources partway through bootstrapping, tch tch, overwriting its version -;;; with our version would be unlikely to help, because that would make the -;;; cross-compiler very confused.) +;;;; info classes, info types, and type numbers, part I: what's needed +;;;; not only at compile time but also at run time + +;;;; Note: This section is a blast from the past, a little trip down +;;;; memory lane to revisit the weird host/target interactions of the +;;;; CMU CL build process. Because of the way that the cross-compiler +;;;; and target compiler share stuff here, if you change anything in +;;;; here, you'd be well-advised to nuke all your fasl files and +;;;; restart compilation from the very beginning of the bootstrap +;;;; process. + +;;; At run time, we represent the type of info that we want by a small +;;; non-negative integer. +(defconstant type-number-bits 6) +(deftype type-number () `(unsigned-byte ,type-number-bits)) + +;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're +;;; running the cross-compiler? The cross-compiler (which was built +;;; from these sources) has its version of these data and functions +;;; defined in the same places we'd be defining into. We're happy with +;;; its version, since it was compiled from the same sources, so +;;; there's no point in overwriting its nice compiled version of this +;;; stuff with our interpreted version. (And any time we're *not* +;;; happy with its version, perhaps because we've been editing the +;;; sources partway through bootstrapping, tch tch, overwriting its +;;; version with our version would be unlikely to help, because that +;;; would make the cross-compiler very confused.) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defstruct (class-info @@ -118,11 +125,6 @@ ;; List of Type-Info structures for each type in this class. (types () :type list)) -;;; At run time, we represent the type of info that we want by a small -;;; non-negative integer. -(defconstant type-number-bits 6) -(deftype type-number () `(unsigned-byte ,type-number-bits)) - ;;; a map from type numbers to TYPE-INFO objects. There is one type ;;; number for each defined CLASS/TYPE pair. ;;; @@ -536,8 +538,8 @@ (values)) -;;; Exact density (modulo rounding) of the hashtable in a compact info -;;; environment in names/bucket. +;;; the exact density (modulo rounding) of the hashtable in a compact +;;; info environment in names/bucket (defconstant compact-info-environment-density 65) ;;; Iterate over the environment once to find out how many names and entries @@ -822,9 +824,11 @@ whole))) |# -;;; the maximum density of the hashtable in a volatile env (in names/bucket) -;;; FIXME: actually seems to be measured in percent, should be converted -;;; to be measured in names/bucket +;;; the maximum density of the hashtable in a volatile env (in +;;; names/bucket) +;;; +;;; FIXME: actually seems to be measured in percent, should be +;;; converted to be measured in names/bucket (defconstant volatile-info-environment-density 50) ;;; Make a new volatile environment of the specified size. diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index fdb8a02..b825192 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -923,7 +923,7 @@ ;;; Parse an inline/notinline declaration. If it's a local function we're ;;; defining, set its INLINEP. If a global function, add a new FENV entry. (defun process-inline-declaration (spec res fvars) - (let ((sense (cdr (assoc (first spec) inlinep-translations :test #'eq))) + (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) (new-fenv ())) (dolist (name (rest spec)) (let ((fvar (find name fvars :key #'leaf-name :test #'equal))) @@ -1347,24 +1347,24 @@ (values)) ;;; Create a lambda node out of some code, returning the result. The -;;; bindings are specified by the list of var structures Vars. We deal -;;; with adding the names to the Lexenv-Variables for the conversion. -;;; The result is added to the New-Functions in the -;;; *Current-Component* and linked to the component head and tail. +;;; bindings are specified by the list of VAR structures VARS. We deal +;;; with adding the names to the LEXENV-VARIABLES for the conversion. +;;; The result is added to the NEW-FUNCTIONS in the +;;; *CURRENT-COMPONENT* and linked to the component head and tail. ;;; -;;; We detect special bindings here, replacing the original Var in the +;;; We detect special bindings here, replacing the original VAR in the ;;; lambda list with a temporary variable. We then pass a list of the -;;; special vars to IR1-Convert-Special-Bindings, which actually emits +;;; special vars to IR1-CONVERT-SPECIAL-BINDINGS, which actually emits ;;; the special binding code. ;;; -;;; We ignore any Arg-Info in the Vars, trusting that someone else is +;;; We ignore any ARG-INFO in the VARS, trusting that someone else is ;;; dealing with &nonsense. ;;; -;;; Aux-Vars is a list of Var structures for variables that are to be -;;; sequentially bound. Each Aux-Val is a form that is to be evaluated -;;; to get the initial value for the corresponding Aux-Var. Interface -;;; is a flag as T when there are real aux values (see let* and -;;; ir1-convert-aux-bindings.) +;;; AUX-VARS is a list of VAR structures for variables that are to be +;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated +;;; to get the initial value for the corresponding AUX-VAR. Interface +;;; is a flag as T when there are real aux values (see LET* and +;;; IR1-CONVERT-AUX-BINDINGS.) (defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals interface result) (declare (list body vars aux-vars aux-vals) @@ -2063,7 +2063,7 @@ ;;; inhibit evaluation of any enclosed EVAL-WHENs, either by IR1 ;;; conversion done by EVAL, or by conversion of the body for ;;; load-time processing. If *ALREADY-EVALED-THIS* is true then we *do -;;; not* eval since some enclosing eval-when already did. +;;; not* EVAL since some enclosing EVAL-WHEN already did. ;;; ;;; We know we are EVAL'ing for LOAD since we wouldn't get called ;;; otherwise. If LOAD is a situation we call FUN on body. If we @@ -2086,7 +2086,31 @@ (not sb!eval::*already-evaled-this*))) (sb!eval::*already-evaled-this* t)) (when do-eval - (eval `(progn ,@body))) + + ;; This is the natural way to do it. + #-(and sb-xc-host (or sbcl cmu)) + (eval `(progn ,@body)) + + ;; This is a disgusting hack to work around bug IR1-3 when using + ;; SBCL (or CMU CL, for that matter) as a cross-compilation + ;; host. When we go from the cross-compiler (where we bound + ;; SB!EVAL::*ALREADY-EVALED-THIS*) to the host compiler (which + ;; has a separate SB-EVAL::*ALREADY-EVALED-THIS* variable), EVAL + ;; would go and executes nested EVAL-WHENs even when they're not + ;; toplevel forms. Using EVAL-WHEN instead of bare EVAL causes + ;; the cross-compilation host to bind its own + ;; *ALREADY-EVALED-THIS* variable, so that the problem is + ;; suppressed. + ;; + ;; FIXME: Once bug IR1-3 is fixed, this hack can go away. (Or if + ;; CMU CL doesn't fix the bug, then this hack can be made + ;; conditional on #+CMU.) + #+(and sb-xc-host (or sbcl cmu)) + (let (#+sbcl (sb-eval::*already-evaled-this* t) + #+cmu (stub:probably similar but has not been tested)) + (eval `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@body)))) + (if (or (intersection '(:load-toplevel load) situations) (and *converting-for-interpreter* (intersection '(:execute eval) situations))) @@ -2098,11 +2122,37 @@ "EVAL-WHEN (Situation*) Form* Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL. This is conceptually a compile-only implementation, so EVAL is a no-op." - (do-eval-when-stuff situations body - #'(lambda (forms) - (ir1-convert-progn-body start cont forms)))) -;;; Like DO-EVAL-WHEN-STUFF, only do a macrolet. Fun is not passed any + ;; It's difficult to handle EVAL-WHENs completely correctly in the + ;; cross-compiler. (Common Lisp is not a cross-compiler-friendly + ;; language..) Since we, the system implementors, control not only + ;; the cross-compiler but also the code that it processes, we can + ;; handle this either by making the cross-compiler smarter about + ;; handling EVAL-WHENs (hard) or by avoiding the use of difficult + ;; EVAL-WHEN constructs (relatively easy). However, since EVAL-WHENs + ;; can be generated by many macro expansions, it's not always easy + ;; to detect problems by skimming the source code, so we'll try to + ;; add some code here to help out. + ;; + ;; Nested EVAL-WHENs are tricky. + #+sb-xc-host + (labels ((contains-toplevel-eval-when-p (body-part) + (and (consp body-part) + (or (eq (first body-part) 'eval-when) + (and (member (first body-part) + '(locally macrolet progn symbol-macrolet)) + (some #'contains-toplevel-eval-when-p + (rest body-part))))))) + (/show "testing for nested EVAL-WHENs" body) + (when (some #'contains-toplevel-eval-when-p body) + (compiler-style-warning "nested EVAL-WHENs in cross-compilation"))) + + (do-eval-when-stuff situations + body + (lambda (forms) + (ir1-convert-progn-body start cont forms)))) + +;;; Like DO-EVAL-WHEN-STUFF, only do a MACROLET. FUN is not passed any ;;; arguments. (defun do-macrolet-stuff (definitions fun) (declare (list definitions) (type function fun)) @@ -2859,13 +2909,18 @@ ;;;; interface to defining macros -;;;; DEFMACRO, DEFUN and DEFCONSTANT expand into calls to %DEFxxx -;;;; functions so that we get a chance to see what is going on. We -;;;; define IR1 translators for these functions which look at the -;;;; definition and then generate a call to the %%DEFxxx function. +;;;; FIXME: +;;;; classic CMU CL comment: +;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions +;;;; so that we get a chance to see what is going on. We define +;;;; IR1 translators for these functions which look at the +;;;; definition and then generate a call to the %%DEFxxx function. +;;;; Alas, this implementation doesn't do the right thing for +;;;; non-toplevel uses of these forms, so this should probably +;;;; be changed to use EVAL-WHEN instead. ;;; Return a new source path with any stuff intervening between the -;;; current path and the first form beginning with Name stripped off. +;;; current path and the first form beginning with NAME stripped off. ;;; This is used to hide the guts of DEFmumble macros to prevent ;;; annoying error messages. (defun revert-source-path (name) @@ -2957,80 +3012,6 @@ (when sb!xc:*compile-print* ;; MNA compiler message patch (compiler-mumble "~&; converted ~S~%" name)))) - -;;; Update the global environment to correspond to the new definition. -(def-ir1-translator %defconstant ((name value doc) start cont - :kind :function) - (let ((name (eval name)) - (newval (eval value))) - (unless (symbolp name) - (compiler-error "constant name not a symbol: ~S" name)) - (when (eq name t) - (compiler-error "The value of T can't be changed.")) - (when (eq name nil) - (compiler-error "Nihil ex nihil. (can't change NIL)")) - (when (keywordp name) - (compiler-error "Keyword values can't be changed.")) - - (let ((kind (info :variable :kind name))) - (case kind - (:constant - ;; Note: This behavior (disparaging any non-EQL modification) - ;; is unpopular, but it is specified by ANSI (i.e. ANSI says - ;; a non-EQL change has undefined consequences). I think it's - ;; a bad idea to encourage nonconforming programming style - ;; even if it's convenient. If people really want things - ;; which are constant in some sense other than EQL, I suggest - ;; either just using DEFVAR (which is what I generally do), - ;; or defining something like this (untested) code: - ;; (DEFMACRO DEFCONSTANT-EQX (SYMBOL EXPR EQX &OPTIONAL DOC) - ;; "This macro is to be used instead of DEFCONSTANT for values - ;; which are appropriately compared using the function given by - ;; the EQX argument instead of EQL." - ;; (LET ((EXPR-TMP (GENSYM "EXPR-TMP-"))) - ;; `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - ;; (LET ((,EXPR-TMP ,EXPR)) - ;; (UNLESS (AND (BOUNDP ,SYMBOL) - ;; (CONSTANTP ,SYMBOL) - ;; (FUNCALL ,EQX - ;; (SYMBOL-VALUE ,SYMBOL) - ;; ,EXPR-TMP)) - ;; (DEFCONSTANT ,SYMBOL ,EXPR ,@(WHEN DOC `(,DOC)))))))) - ;; I prefer using DEFVAR, though, first because it's trivial, - ;; and second because using DEFCONSTANT lets the compiler - ;; optimize code by removing indirection, copying the current - ;; value of the constant directly into the code, and for - ;; consed data structures, this optimization can become a - ;; pessimization. (And consed data structures are exactly - ;; where you'd be tempted to use DEFCONSTANT-EQX.) Why is - ;; this a pessimization? It does remove a layer of - ;; indirection, but it makes it hard for the system's - ;; load/dump logic to see that all references to the consed - ;; data structure refer to the same (EQ) object. If you use - ;; something like DEFCONSTANT-EQX, you'll tend to get one - ;; copy of the data structure bound to the symbol, and one - ;; more copy for each file where code refers to the constant. - ;; If you're moderately clever with MAKE-LOAD-FORM, you might - ;; be able to make the copy bound to the symbol at load time - ;; be EQ to the references in code in the same file, but it - ;; seems to be rather tricky to force code in different files - ;; to refer the same copy without doing the DEFVAR thing of - ;; indirection through a symbol. -- WHN 2000-11-02 - (unless (eql newval - (info :variable :constant-value name)) - (compiler-warning "redefining constant ~S as:~% ~S" name newval))) - (:global) - (t - (compiler-warning "redefining ~(~A~) ~S to be a constant" - kind - name)))) - - (setf (info :variable :kind name) :constant) - (setf (info :variable :where-from name) :defined) - (setf (info :variable :constant-value name) newval) - (remhash name *free-variables*)) - - (ir1-convert start cont `(%%defconstant ,name ,value ,doc))) ;;;; defining global functions @@ -3095,7 +3076,7 @@ (global-var (when (defined-function-p what) (push `(,(car (rassoc (defined-function-inlinep what) - inlinep-translations)) + *inlinep-translations*)) ,name) decls))) (t (return t)))))) diff --git a/src/compiler/late-macros.lisp b/src/compiler/late-macros.lisp index 9d617f2..dfd305c 100644 --- a/src/compiler/late-macros.lisp +++ b/src/compiler/late-macros.lisp @@ -33,7 +33,7 @@ NAME-attributes attribute-name* Return a set of the named attributes." - (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS")) + (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*")) (test-name (symbolicate name "-ATTRIBUTEP"))) (collect ((alist)) (do ((mask 1 (ash mask 1)) @@ -42,13 +42,15 @@ (alist (cons (car names) mask))) `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,const-name ',(alist))) + (defparameter ,translations-name ',(alist))) (defmacro ,test-name (attributes &rest attribute-names) "Automagically generated boolean attribute test function. See Def-Boolean-Attribute." - `(logtest ,(compute-attribute-mask attribute-names ,const-name) + `(logtest ,(compute-attribute-mask attribute-names + ,translations-name) (the attributes ,attributes))) (define-setf-expander ,test-name (place &rest attributes @@ -60,14 +62,14 @@ env (compute-attribute-mask attributes - ,const-name + ,translations-name ) ',test-name)) (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) "Automagically generated boolean attribute creation function. See Def-Boolean-Attribute." - (compute-attribute-mask attribute-names ,const-name)))))) + (compute-attribute-mask attribute-names ,translations-name)))))) ;;; a helper function for the cross-compilation target Lisp code which ;;; DEF-BOOLEAN-ATTRIBUTE expands into diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 72f9278..1717b27 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -242,7 +242,7 @@ NAME-attributes attribute-name* Return a set of the named attributes." - (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS")) + (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*")) (test-name (symbolicate name "-ATTRIBUTEP"))) (collect ((alist)) (do ((mask 1 (ash mask 1)) @@ -251,13 +251,15 @@ (alist (cons (car names) mask))) `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,const-name ',(alist))) + (defparameter ,translations-name ',(alist))) (defmacro ,test-name (attributes &rest attribute-names) "Automagically generated boolean attribute test function. See Def-Boolean-Attribute." - `(logtest ,(compute-attribute-mask attribute-names ,const-name) + `(logtest ,(compute-attribute-mask attribute-names + ,translations-name) (the attributes ,attributes))) (define-setf-expander ,test-name (place &rest attributes @@ -274,7 +276,8 @@ (error "multiple store variables for ~S" place)) (let ((newval (gensym)) (n-place (gensym)) - (mask (compute-attribute-mask attributes ,const-name))) + (mask (compute-attribute-mask attributes + ,translations-name))) (values `(,@temps ,n-place) `(,@values ,get) `(,newval) @@ -289,7 +292,7 @@ (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) "Automagically generated boolean attribute creation function. See Def-Boolean-Attribute." - (compute-attribute-mask attribute-names ,const-name)))))) + (compute-attribute-mask attribute-names ,translations-name)))))) ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806 ;;; And now for some gratuitous pseudo-abstraction... diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index bea61a6..8c542f9 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -233,8 +233,10 @@ (sb!assem:assemble (*code-segment* ,(first lambda-list)) ,@body)))) -(defconstant sc-vop-slots '((:move . sc-move-vops) - (:move-argument . sc-move-arg-vops))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *sc-vop-slots* + '((:move . sc-move-vops) + (:move-argument . sc-move-arg-vops)))) ;;; We record the VOP and costs for all SCs that we can move between ;;; (including implicit loading). @@ -246,7 +248,7 @@ an extra argument, which is the frame pointer of the frame to move into." (when (or (oddp (length scs)) (null scs)) (error "malformed SCs spec: ~S" scs)) - (let ((accessor (or (cdr (assoc kind sc-vop-slots)) + (let ((accessor (or (cdr (assoc kind *sc-vop-slots*)) (error "unknown kind ~S" kind)))) `(progn ,@(when (eq kind :move) @@ -1420,8 +1422,9 @@ ;;;; setting up VOP-INFO -(defconstant slot-inherit-alist - '((:generator-function . vop-info-generator-function))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *slot-inherit-alist* + '((:generator-function . vop-info-generator-function)))) ;;; Something to help with inheriting VOP-Info slots. We return a ;;; keyword/value pair that can be passed to the constructor. Slot is the @@ -1432,7 +1435,7 @@ ;;; we return the Form so that the slot is recomputed. (defmacro inherit-vop-info (slot parse test form) `(if (and ,parse ,test) - (list ,slot `(,',(or (cdr (assoc slot slot-inherit-alist)) + (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*)) (error "unknown slot ~S" slot)) (template-or-lose ',(vop-parse-name ,parse)))) (list ,slot ,form))) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 0669cab..7dcfa27 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -130,6 +130,8 @@ (dolist (name args) (unless (symbolp name) (error "can't declare a non-symbol as SPECIAL: ~S" name)) + (when (constantp name) + (error "can't declare a constant as SPECIAL: ~S" name)) (clear-info :variable :constant-value name) (setf (info :variable :kind name) :special))) (type diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index 823d7c2..4f893d6 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -209,20 +209,21 @@ ;;;; representation selection -;;; VOPs that we ignore in initial cost computation. We ignore SET in the -;;; hopes that nobody is setting specials inside of loops. We ignore -;;; TYPE-CHECK-ERROR because we don't want the possibility of error to bias the -;;; result. Notes are suppressed for T-C-E as well, since we don't need to -;;; worry about the efficiency of that case. -(defconstant ignore-cost-vops '(set type-check-error)) -(defconstant suppress-note-vops '(type-check-error)) - -;;; We special-case the move VOP, since using this costs for the normal MOVE -;;; would spuriously encourage descriptor representations. We won't actually -;;; need to coerce to descriptor and back, since we will replace the MOVE with -;;; a specialized move VOP. What we do is look at the other operand. If its -;;; representation has already been chosen (e.g. if it is wired), then we use -;;; the appropriate move costs, otherwise we just ignore the references. +;;; VOPs that we ignore in initial cost computation. We ignore SET in +;;; the hopes that nobody is setting specials inside of loops. We +;;; ignore TYPE-CHECK-ERROR because we don't want the possibility of +;;; error to bias the result. Notes are suppressed for T-C-E as well, +;;; since we don't need to worry about the efficiency of that case. +(defparameter *ignore-cost-vops* '(set type-check-error)) +(defparameter *suppress-note-vops* '(type-check-error)) + +;;; We special-case the move VOP, since using this costs for the +;;; normal MOVE would spuriously encourage descriptor representations. +;;; We won't actually need to coerce to descriptor and back, since we +;;; will replace the MOVE with a specialized move VOP. What we do is +;;; look at the other operand. If its representation has already been +;;; chosen (e.g. if it is wired), then we use the appropriate move +;;; costs, otherwise we just ignore the references. (defun add-representation-costs (refs scs costs ops-slot costs-slot more-costs-slot write-p) @@ -236,34 +237,34 @@ (incf (svref costs scn) res))))) (let* ((vop (tn-ref-vop ref)) (info (vop-info vop))) - (case (vop-info-name info) - (#.ignore-cost-vops) - (move - (let ((rep (tn-sc - (tn-ref-tn - (if write-p - (vop-args vop) - (vop-results vop)))))) - (when rep - (if write-p - (dolist (scn scs) - (let ((res (svref (sc-move-costs - (svref *backend-sc-numbers* scn)) - (sc-number rep)))) - (when res - (incf (svref costs scn) res)))) - (dolist (scn scs) - (let ((res (svref (sc-move-costs rep) scn))) - (when res - (incf (svref costs scn) res)))))))) - (t - (do ((cost (funcall costs-slot info) (cdr cost)) - (op (funcall ops-slot vop) (tn-ref-across op))) - ((null cost) - (add-costs (funcall more-costs-slot info))) - (when (eq op ref) - (add-costs (car cost)) - (return)))))))) + (unless (find (vop-info-name info) *ignore-cost-vops*) + (case (vop-info-name info) + (move + (let ((rep (tn-sc + (tn-ref-tn + (if write-p + (vop-args vop) + (vop-results vop)))))) + (when rep + (if write-p + (dolist (scn scs) + (let ((res (svref (sc-move-costs + (svref *backend-sc-numbers* scn)) + (sc-number rep)))) + (when res + (incf (svref costs scn) res)))) + (dolist (scn scs) + (let ((res (svref (sc-move-costs rep) scn))) + (when res + (incf (svref costs scn) res)))))))) + (t + (do ((cost (funcall costs-slot info) (cdr cost)) + (op (funcall ops-slot vop) (tn-ref-across op))) + ((null cost) + (add-costs (funcall more-costs-slot info))) + (when (eq op ref) + (add-costs (car cost)) + (return))))))))) (values)) ;;; Return the best representation for a normal TN. SCs is a list @@ -354,7 +355,7 @@ (*compiler-error-context* op-node)) (cond ((eq (tn-kind op-tn) :constant)) ((policy op-node (<= speed brevity) (<= space brevity))) - ((member (template-name (vop-info op-vop)) suppress-note-vops)) + ((member (template-name (vop-info op-vop)) *suppress-note-vops*)) ((null dest-tn) (let* ((op-info (vop-info op-vop)) (op-note (or (template-note op-info) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 8c493b1..3bd162c 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -322,13 +322,13 @@ ;;; names of predicates that compute the same value as CHAR= when ;;; applied to characters -(defconstant char=-functions '(eql equal char=)) +(defparameter *char=-functions* '(eql equal char=)) (deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2 test) (simple-string simple-string &rest t)) (unless (or (not test) - (continuation-function-is test char=-functions)) + (continuation-function-is test *char=-functions*)) (give-up-ir1-transform)) '(sb!impl::%sp-string-search string1 start1 (or end1 (length string1)) string2 start2 (or end2 (length string2)))) @@ -336,7 +336,7 @@ (deftransform position ((item sequence &key from-end test (start 0) end) (t simple-string &rest t)) (unless (or (not test) - (continuation-function-is test char=-functions)) + (continuation-function-is test *char=-functions*)) (give-up-ir1-transform)) `(and (typep item 'character) (,(if (constant-value-or-lose from-end) @@ -355,8 +355,8 @@ ;;;; utilities -;;; Return true if Cont's only use is a non-notinline reference to a global -;;; function with one of the specified Names. +;;; Return true if CONT's only use is a non-notinline reference to a +;;; global function with one of the specified NAMES. (defun continuation-function-is (cont names) (declare (type continuation cont) (list names)) (let ((use (continuation-use cont))) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index c634cda..b10ba0b 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1788,7 +1788,7 @@ ;;; routines to find things in the Lisp environment -(defconstant groked-symbol-slots +(defparameter *grokked-symbol-slots* (sort `((,sb!vm:symbol-value-slot . symbol-value) (,sb!vm:symbol-plist-slot . symbol-plist) (,sb!vm:symbol-name-slot . symbol-name) @@ -1808,7 +1808,7 @@ symbol object that we know about.") (declare (type address address)) (if (not (aligned-p address sb!vm:word-bytes)) (values nil nil) - (do ((slots-tail groked-symbol-slots (cdr slots-tail))) + (do ((slots-tail *grokked-symbol-slots* (cdr slots-tail))) ((null slots-tail) (values nil nil)) (let* ((field (car slots-tail)) diff --git a/src/compiler/trace-table.lisp b/src/compiler/trace-table.lisp index 1f93fb4..b25f0a1 100644 --- a/src/compiler/trace-table.lisp +++ b/src/compiler/trace-table.lisp @@ -17,19 +17,20 @@ (push (cons label state) *trace-table-info*)) (values)) -;;; Convert the list of (label . state) entries into an ivector. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant tt-bits-per-state 3) - (defconstant tt-bytes-per-entry 2) - (defconstant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:byte-bits)) - (defconstant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state)) - (defconstant tt-max-offset (1- (ash 1 tt-bits-per-offset)))) +(defconstant tt-bits-per-state 3) +(defconstant tt-bytes-per-entry 2) +(defconstant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:byte-bits)) +(defconstant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state)) +(defconstant tt-max-offset (1- (ash 1 tt-bits-per-offset))) + (deftype tt-state () `(unsigned-byte ,tt-bits-per-state)) (deftype tt-entry () `(unsigned-byte ,tt-bits-per-entry)) (deftype tt-offset () `(unsigned-byte ,tt-bits-per-offset)) + +;;; Convert the list of (LABEL . STATE) entries into an ivector. (declaim (ftype (function (list) (simple-array tt-entry 1)) pack-trace-table)) (defun pack-trace-table (entries) (declare (list entries)) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 71f8948..b4316cc 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -12,10 +12,9 @@ (in-package "SB!C") -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; the largest number of TNs whose liveness changes that we can have - ;; in any block - (defconstant local-tn-limit 64)) +;;; the largest number of TNs whose liveness changes that we can have +;;; in any block +(defconstant local-tn-limit 64) (deftype local-tn-number () `(integer 0 (,local-tn-limit))) (deftype local-tn-count () `(integer 0 ,local-tn-limit)) @@ -355,9 +354,9 @@ return-pc return-pc-pass) -;;; The Return-Info structure is used by GTN to represent the return strategy -;;; and locations for all the functions in a given Tail-Set. It is stored in -;;; the Tail-Set-Info. +;;; The RETURN-INFO structure is used by GTN to represent the return +;;; strategy and locations for all the functions in a given TAIL-SET. +;;; It is stored in the TAIL-SET-INFO. (defstruct return-info ;; The return convention used: ;; -- If :Unknown, we use the standard return convention. @@ -380,10 +379,10 @@ locations) (defstruct ir2-nlx-info - ;; If the kind is :Entry (a lexical exit), then in the home environment, this - ;; holds a Value-Cell object containing the unwind block pointer. In the - ;; other cases nobody directly references the unwind-block, so we leave this - ;; slot null. + ;; If the kind is :ENTRY (a lexical exit), then in the home + ;; environment, this holds a VALUE-CELL object containing the unwind + ;; block pointer. In the other cases nobody directly references the + ;; unwind-block, so we leave this slot null. (home nil :type (or tn null)) ;; The saved control stack pointer. (save-sp (required-argument) :type tn) diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 775ef25..1a2461c 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -78,17 +78,17 @@ ("code/defbangtype") ("code/defbangmacro") + ("code/primordial-extensions") + ;; for various constants e.g. SB!VM:*TARGET-MOST-POSITIVE-FIXNUM* and ;; SB!VM:LOWTAG-BITS, needed by "early-objdef" and others ("compiler/generic/early-vm") - ("compiler/generic/early-vm-macs") ("compiler/generic/early-objdef") ("compiler/target/parms") ("code/early-array") ; needs "early-vm" numbers ("code/parse-body") ; on host for PARSE-BODY ("code/parse-defmacro") ; on host for PARSE-DEFMACRO - ("code/early-defboot") ; on host for FILE-COMMENT, DO-ANONYMOUS, etc. ("code/boot-extensions") ; on host for COLLECT etc. ("code/early-extensions") ; on host for SYMBOLICATE etc. ("code/late-extensions") ; FIXME: maybe no longer needed on host now that diff --git a/version.lisp-expr b/version.lisp-expr index 34e2783..9bf9840 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.8.8" +"0.6.8.9"