;;; and there's also the noted-below problem that the C-level code
;;; contains implicit assumptions about this marker.
;;;
-;;; KLUDGE: Note that as of version 0.6.6 there's a dependence in the
+;;; KLUDGE: Note that as of version 0.pre7 there's a dependence in the
;;; gencgc.c code on this value being a symbol. (This is only one of
-;;; many nasty dependencies between that code and this, alas.)
-;;; -- WHN 2001-02-28
-(defconstant +empty-ht-slot+ '%empty-ht-slot%)
+;;; several nasty dependencies between that code and this, alas.)
+;;; -- WHN 2001-08-17
+;;;
+;;; FIXME: We end up doing two DEFCONSTANT forms because (1) LispWorks
+;;; needs EVAL-WHEN wrapped around DEFCONSTANT, and (2) SBCL's
+;;; DEFCONSTANT expansion doesn't seem to behave properly inside
+;;; EVAL-WHEN, so that without this, the +EMPTY-HT-SLOT+ references in
+;;; e.g. DOHASH macroexpansions don't end up being replaced by
+;;; constant values, so that the system dies at cold init because
+;;; '+EMPTY-HT-SLOT+ isn't bound yet. It's hard to fix this properly
+;;; until SBCL's EVAL-WHEN is fixed, which is waiting for the IR1
+;;; interpreter to go away, which is waiting for sbcl-0.7.x..
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +empty-ht-slot+ '%empty-ht-slot%))
+;;; We shouldn't need this mess now that EVAL-WHEN works.
+#+nil (defconstant +empty-ht-slot+ '#.+empty-ht-slot+) ; egads.. See FIXME above.
;;; KLUDGE: Using a private symbol still leaves us vulnerable to users
;;; getting nonconforming behavior by messing around with
;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for
;;;; 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)
+ (defun frob-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))
;;; EXIT-FORMS are evaluated as a PROGN, with the result being the
;;; value of the DO.
(defmacro do-anonymous (varlist endlist &rest body)
- (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
+ (frob-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
\f
;;;; miscellany
+;;; 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"))
+
;;; Concatenate together the names of some strings and symbols,
;;; producing a symbol in the current package.
(eval-when (:compile-toplevel :load-toplevel :execute)
(type-of maybe-package))
'*package* really-package)))))))
+;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value
+;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't
+;;; actually need to reset the variable when it's silly, since even
+;;; crazy values of *DEFAULT-PATHNAME-DEFAULTS* don't leave the system
+;;; in a state where it's hard to recover interactively.)
+(defun sane-default-pathname-defaults ()
+ (let* ((dfd *default-pathname-defaults*)
+ (dfd-dir (pathname-directory dfd)))
+ ;; It's generally not good to use a relative pathname for
+ ;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames
+ ;; are defined by merging into a default pathname (which is,
+ ;; by default, *DEFAULT-PATHNAME-DEFAULTS*).
+ (when (and (consp dfd-dir)
+ (eql (first dfd-dir) :relative))
+ (warn
+ "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
+ '*default-pathname-defaults*))
+ dfd))
+
;;; Give names to elements of a numeric sequence.
(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
&rest identifiers)
;;; 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.
+;;; probably use DEFPARAMETER instead; or if you truly desperately
+;;; need to avoid runtime indirection through a symbol, you might be
+;;; able to do something with LOAD-TIME-VALUE or MAKE-LOAD-FORM.
(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))
- (cond ((boundp ',symbol)
- (unless (and (constantp ',symbol)
- (funcall ,eqx
- (symbol-value ',symbol)
- ,expr-tmp))
- (error "already bound differently: ~S")))
- (t
- (defconstant ,symbol
- ;; KLUDGE: This is a very ugly hack, to be able to
- ;; build SBCL with CMU CL (2.4.19), because there
- ;; seems to be some confusion in CMU CL about
- ;; ,EXPR-TEMP at EVAL-WHEN time ... -- MNA 2000-02-23
- #-cmu ,expr-tmp
- #+cmu ,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 ,symbol))
- (unless (and (eql (info :variable :kind ',symbol) :constant)
- (funcall ,eqx
- (info :variable :constant-value ',symbol)
- ,expr-tmp))
- (sb!c::%defconstant ',symbol ,expr-tmp ,doc)))))))
+ `(defconstant ,symbol
+ (%defconstant-eqx-value ',symbol ,expr ,eqx)
+ ,@(when doc (list doc))))
+(defun %defconstant-eqx-value (symbol expr eqx)
+ (flet ((bummer (explanation)
+ (error "~@<bad DEFCONSTANT-EQX ~S ~2I~_~S: ~2I~_~A ~S~:>"
+ symbol
+ expr
+ explanation
+ (symbol-value symbol))))
+ (cond ((not (boundp symbol))
+ expr)
+ ((not (constantp symbol))
+ (bummer "already bound as a non-constant"))
+ ((not (funcall eqx (symbol-value symbol) expr))
+ (bummer "already bound as a different constant value"))
+ (t
+ (symbol-value symbol)))))
projects / sbcl.git / blobdiff