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
(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.
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
(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"))
#
# 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)
# 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.
"ITERATE"
"LETF" "LETF*"
"ONCE-ONLY"
+ "DEFENUM"
"DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
;; encapsulation
;; 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"
"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
"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"
\f
;;;; 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
\f
;;;; internal inline routines
\f
;;;; 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.")
#!+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))
(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))))
\f
;;;; 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.
;;;
`(labels ((,name ,(mapcar #'first binds) ,@body))
(,name ,@(mapcar #'second binds))))
\f
-;;; 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*
;; 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))))
`(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))
;;;; 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)
;;;; ...more <kind, delta, top-level form offset, form-number, live-set>
;;;; 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))
\f
;;;; DEBUG-FUNCTION objects
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))
\f
;;;; debug source
(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)))
(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
#!+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)
(%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))))
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)
+++ /dev/null
-;;;; 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))))
-\f
-;;;; 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)))
(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
;;;
(defconstant escape-char-code 27)
(defconstant rubout-char-code 127)
\f
-;;; 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)))
-\f
;;;; miscellaneous iteration extensions
(defmacro dovector ((elt vector &optional result) &rest forms)
(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.)
+ ))
\f
#|
;;; REMOVEME when done testing byte cross-compiler
(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)
(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)
(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
(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)))
,@(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)))))
-;;; 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.
(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)
(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
;;; 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)
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
(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
(: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)))
(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~]~]]"
(not (zerop seconds))
(abs seconds))))))
-;;; Format-Decoded-Time - External.
(defun format-decoded-time (destination seconds minutes hours
day month year
&key (timezone nil)
(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)
(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)
(: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"))))
;;; 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
;;; 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))
(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)))
#!+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)))
\f
;;;; 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)
\f
;;;; DEFINE-COMPILER-MACRO
--- /dev/null
+;;;; 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")
+
+\f
+;;;; 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)))
+\f
+;;;; 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)))))))
(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.
(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)
(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 ()
\f
;;;; 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)
\f
;;;; macros and functions for character tables
\f
;;;; 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
(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*))
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
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))
;;; -- 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)
;; 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))))
;; 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))))
(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))))
(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. "
"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))
(setf (symbol-function new-symbol) (symbol-function symbol))))
new-symbol)
+;;; FIXME: This declaration should be redundant.
(declaim (special *keyword-package*))
(defun keywordp (object)
\f
;;;; 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
((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)))
(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)
(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)
(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
\f
;;;; 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))
\f
;;;; 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))))
(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
;; 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"))
(/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*))
\f
(!cold-init-forms
(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))
;;; 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
\f
;;;; mixing hash values
(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)
: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)
(: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
(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)))
(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)
(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?)))))
(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))))
(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*)))
#!+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
(void-syscall ("close" int) fd))
\f
;;; fcntlbits.h
-(eval-when (:compile-toplevel :load-toplevel :execute)
(/show0 "unix.lisp 337")
(defconstant o_rdonly 0) ; read-only flag
#!+linux #o2000
#!+bsd #x0008)
(/show0 "unix.lisp 361")
-) ; EVAL-WHEN
\f
;;;; timebits.h
((: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
(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)
'(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.
;; 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))
(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)
(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)
(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*)
(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))
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)))))
*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)
(values (copy-seq *byte-buffer*) tlf-num)))
\f
-;;; 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)))
(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)
(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))
(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))
(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)))
\f
;;;; 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))
(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)
: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))
\f
;;;; minimal debug functions
-;;; Return true if Dfun can be represented as a minimal debug function.
-;;; Dfun is a cons (<start offset> . C-D-F).
+;;; Return true if DFUN can be represented as a minimal debug
+;;; function. DFUN is a cons (<start offset> . 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))
(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)
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)
(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
(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)))))
\f
-;;; 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)
(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*
(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")
\f
;;;; cross-compiler-only versions of CL special variables, so that we
(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)
: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*))
;;; 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)))
(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))
;; 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)))
;;;; 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*
+++ /dev/null
-;;;; 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))))
(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.")
#!+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
;;;
;;; 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
(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)
(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))
((sb!sys:positive-primep n)
n)))
\f
-;;;; 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
;; 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.
;;;
(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
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.
;;; 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)))
(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)
;;; 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
(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)))
"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))
\f
;;;; 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)
(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)))
\f
;;;; defining global functions
(global-var
(when (defined-function-p what)
(push `(,(car (rassoc (defined-function-inlinep what)
- inlinep-translations))
+ *inlinep-translations*))
,name)
decls)))
(t (return t))))))
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))
(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
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
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))
(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
(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)
(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...
(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).
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)
\f
;;;; 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
;;; 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)))
(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
\f
;;;; 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)
(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
(*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)
;;; 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))))
(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)
\f
;;;; 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)))
\f
;;; 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)
(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))
(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))
(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))
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.
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)
("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
;;; 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"
projects / sbcl.git / commitdiff