0.6.11.6:

[sbcl.git] / src / code / primordial-extensions.lisp

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index 9facae7..3a8a71d 100644 (file)
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -68,36 +68,38 @@
                   (unless ,(first endlist) (go ,label-1))
                   (return-from ,block (progn ,@(rest endlist))))))))))
 
+;;; DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
+;;;
+;;; 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)))
 \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)))))
+(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*))
@@ -120,7 +122,7 @@
                    :datum maybe-package
                    :expected-type 'package
                    :format-control
-                   "~S can't be a ~S:~%  ~S has been reset to ~S"
+                   "~@<~S can't be a ~S: ~2I~_~S has been reset to ~S.~:>"
                    :format-arguments (list '*package* (type-of maybe-package)
                                            '*package* really-package)))))))
 
@@ -137,8 +139,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)
@@ -175,10 +175,21 @@
        ;; 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))))))
+          (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
@@ -193,7 +204,7 @@
        ;; instead. -- WHN 2000-11-03
        #+sb-xc
        (eval-when (:compile-toplevel)
-        (let ((,expr-tmp ,expr))
+        (let ((,expr-tmp ,symbol))
           (unless (and (eql (info :variable :kind ',symbol) :constant)
                        (funcall ,eqx
                                 (info :variable :constant-value ',symbol)