X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprimordial-extensions.lisp;h=9e7eb4782842c52375457f38df67e7fb773b8c92;hb=334af30b26555f0bf706f7157b399bdbd4fad548;hp=ecbc70a64cf06af4fde3a106418a1107099758f4;hpb=92f6ecdad23faf8b1677c24aa57c5eaec96d9c82;p=sbcl.git diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index ecbc70a..9e7eb47 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -12,6 +12,46 @@ (in-package "SB!INT") +;;;; target constants which need to appear as early as possible + +;;; an internal tag for marking empty slots, which needs to be defined +;;; as early as possible because it appears in macroexpansions for +;;; iteration over hash tables +;;; +;;; CMU CL 18b used :EMPTY for this purpose, which was somewhat nasty +;;; since it's easily accessible to the user, so that e.g. +;;; (DEFVAR *HT* (MAKE-HASH-TABLE)) +;;; (SETF (GETHASH :EMPTY *HT*) :EMPTY) +;;; (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V))) +;;; gives no output -- oops! +;;; +;;; FIXME: It'd probably be good to use the unbound marker for this. +;;; However, there might be some gotchas involving assumptions by +;;; e.g. AREF that they're not going to return the unbound marker, +;;; 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 +;;; 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%) +;;; 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 +;;; now we just don't worry about it. If for some reason it becomes +;;; worrisome and the magic value needs replacement: +;;; * The replacement value needs to be LOADable with EQL preserved, +;;; so that macroexpansion for WITH-HASH-TABLE-ITERATOR will work +;;; when compiled into a file and loaded back into SBCL. +;;; (Thus, just uninterning %EMPTY-HT-SLOT% doesn't work.) +;;; * The replacement value needs to be acceptable to the +;;; low-level gencgc.lisp hash table scavenging code. +;;; * The change will break binary compatibility, since comparisons +;;; against the value used at the time of compilation are wired +;;; into FASL files. +;;; -- WHN 20000622 + ;;;; DO-related stuff which needs to be visible on the cross-compilation host (eval-when (:compile-toplevel :load-toplevel :execute) @@ -68,36 +108,36 @@ (unless ,(first endlist) (go ,label-1)) (return-from ,block (progn ,@(rest endlist)))))))))) +;;; This is like DO, except it 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. (defmacro do-anonymous (varlist endlist &rest body) - #!+sb-doc - "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* - Like DO, but has no implicit NIL block. Each Var is initialized in parallel - to the value of the specified Init form. On subsequent iterations, the Vars - are assigned the value of the Step form (if any) in parallel. The Test is - evaluated before each evaluation of the body Forms. When the Test is true, - the Exit-Forms are evaluated as a PROGN, with the result being the value - of the DO." (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym))) ;;;; miscellany ;;; Concatenate together the names of some strings and symbols, ;;; producing a symbol in the current package. -(defun symbolicate (&rest things) - (values (intern (apply #'concatenate - 'string - (mapcar #'string things))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (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))) -;;; Access *PACKAGE* in a way which lets us recover if someone has +;;; Access *PACKAGE* in a way which lets us recover when someone has ;;; done something silly like (SETF *PACKAGE* :CL-USER). (Such an -;;; assignment is undefined behavior, so it's sort of reasonable for it -;;; to cause the system to go totally insane afterwards, but it's -;;; a fairly easy mistake to make, so let's try to recover gracefully +;;; assignment is undefined behavior, so it's sort of reasonable for +;;; it to cause the system to go totally insane afterwards, but it's a +;;; fairly easy mistake to make, so let's try to recover gracefully ;;; instead.) (defun sane-package () (let ((maybe-package *package*)) @@ -118,10 +158,13 @@ ;; Then complain. (error 'simple-type-error :datum maybe-package - :expected-type 'package + :expected-type '(and package (satisfies package-name)) :format-control - "~S can't be a ~S:~% ~S has been reset to ~S" - :format-arguments (list '*package* (type-of maybe-package) + "~@<~S can't be a ~A: ~2I~_~S has been reset to ~S.~:>" + :format-arguments (list '*package* + (if (packagep maybe-package) + "deleted package" + (type-of maybe-package)) '*package* really-package))))))) ;;; Give names to elements of a numeric sequence. @@ -137,8 +180,6 @@ (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) @@ -182,7 +223,14 @@ ,expr-tmp)) (error "already bound differently: ~S"))) (t - (defconstant ,symbol ,expr-tmp ,@(when doc `(,doc))))))) + (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