0.8.12.37:

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

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index b3127f3..7b10afd 100644 (file)
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -10,7 +10,7 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 

-(in-package "SB!INT")
+(in-package "SB!IMPL")

 \f
 ;;;; target constants which need to appear as early as possible
 
 \f
 ;;;; target constants which need to appear as early as possible
 

@@ -31,23 +31,14 @@
 ;;; and there's also the noted-below problem that the C-level code
 ;;; contains implicit assumptions about this 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
+;;; 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
 ;;; 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
-;;;
-;;; 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..
+;;; several nasty dependencies between that code and this, alas.)
+;;; -- WHN 2001-08-17

 (eval-when (:compile-toplevel :load-toplevel :execute)
 (eval-when (:compile-toplevel :load-toplevel :execute)

-  (defconstant +empty-ht-slot+ '%empty-ht-slot%))
-(defconstant +empty-ht-slot+ '#.+empty-ht-slot+) ; egads.. See FIXME above.
+  (def!constant +empty-ht-slot+ '%empty-ht-slot%))
+;;; We shouldn't need this mess now that EVAL-WHEN works.
+

 ;;; 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
 ;;; 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

@@ -66,8 +57,8 @@
 \f
 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
 
 \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)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+  (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))
     (let* ((r-inits nil) ; accumulator for reversed list
           (r-steps nil) ; accumulator for reversed list
           (label-1 (gensym))

@@ -107,18 +98,19 @@
                         (t (illegal-varlist)))))
                (t (illegal-varlist)))))
       ;; Construct the new form.
                         (t (illegal-varlist)))))
                (t (illegal-varlist)))))
       ;; Construct the new form.

-      (multiple-value-bind (code decls) (parse-body decls-and-code nil)
+      (multiple-value-bind (code decls)
+         (parse-body decls-and-code :doc-string-allowed nil)

        `(block ,block
           (,bind ,(nreverse r-inits)
                  ,@decls
                  (tagbody
        `(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))))))))))
+                     (go ,label-2)
+                     ,label-1
+                     (tagbody ,@code)
+                     (,step ,@(nreverse r-steps))
+                     ,label-2
+                     (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.
 
 ;;; 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.

@@ -128,17 +120,77 @@
 ;;; EXIT-FORMS are evaluated as a PROGN, with the result being the
 ;;; value of the DO.
 (defmacro do-anonymous (varlist endlist &rest body)
 ;;; 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
+;;;; GENSYM tricks
+
+;;; Automate an idiom often found in macros:
+;;;   (LET ((FOO (GENSYM "FOO"))
+;;;         (MAX-INDEX (GENSYM "MAX-INDEX-")))
+;;;     ...)
+;;;
+;;; "Good notation eliminates thought." -- Eric Siggia
+;;;
+;;; Incidentally, this is essentially the same operator which
+;;; _On Lisp_ calls WITH-GENSYMS.
+(defmacro with-unique-names (symbols &body body)
+  `(let ,(mapcar (lambda (symbol)
+                  (let* ((symbol-name (symbol-name symbol))
+                         (stem (if (every #'alpha-char-p symbol-name)
+                                   symbol-name
+                                   (concatenate 'string symbol-name "-"))))
+                    `(,symbol (gensym ,stem))))
+                symbols)
+     ,@body))
+
+;;; Return a list of N gensyms. (This is a common suboperation in
+;;; macros and other code-manipulating code.)
+(declaim (ftype (function (index) list) make-gensym-list))
+(defun make-gensym-list (n)
+  (loop repeat n collect (gensym)))

 \f
 ;;;; miscellany
 
 \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.
 ;;; Concatenate together the names of some strings and symbols,
 ;;; producing a symbol in the current package.

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun symbolicate (&rest things)
   (defun symbolicate (&rest things)

-    (values (intern (apply #'concatenate
-                          'string
-                          (mapcar #'string things))))))
+    (let ((name (case (length things)
+                 ;; Why isn't this just the value in the T branch?
+                 ;; Well, this is called early in cold-init, before
+                 ;; the type system is set up; however, now that we
+                 ;; check for bad lengths, the type system is needed
+                 ;; for calls to CONCATENATE. So we need to make sure
+                 ;; that the calls are transformed away:
+                 (1 (concatenate 'string
+                                 (the simple-base-string
+                                   (string (car things)))))
+                 (2 (concatenate 'string 
+                                 (the simple-base-string
+                                   (string (car things)))
+                                 (the simple-base-string
+                                   (string (cadr things)))))
+                 (3 (concatenate 'string
+                                 (the simple-base-string
+                                   (string (car things)))
+                                 (the simple-base-string
+                                   (string (cadr things)))
+                                 (the simple-base-string
+                                   (string (caddr things)))))
+                 (t (apply #'concatenate 'string (mapcar #'string things))))))
+    (values (intern name)))))

 
 ;;; like SYMBOLICATE, but producing keywords
 (defun keywordicate (&rest things)
 
 ;;; like SYMBOLICATE, but producing keywords
 (defun keywordicate (&rest things)

@@ -179,11 +231,11 @@
                                                (type-of maybe-package))
                                            '*package* really-package)))))))
 
                                                (type-of maybe-package))
                                            '*package* really-package)))))))
 

-;;; Access *DEFAULT-PATHNAME-DEFAULTS*, warning if it's 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.)
+;;; 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)))
 (defun sane-default-pathname-defaults ()
   (let* ((dfd *default-pathname-defaults*)
         (dfd-dir (pathname-directory dfd)))

@@ -196,7 +248,7 @@
       (warn
        "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
        '*default-pathname-defaults*))
       (warn
        "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
        '*default-pathname-defaults*))

-    *default-pathname-defaults*))
+    dfd))

 
 ;;; Give names to elements of a numeric sequence.
 (defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
 
 ;;; Give names to elements of a numeric sequence.
 (defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))

@@ -211,7 +263,7 @@
            (if (consp id)
                (values (car id) (cdr id))
                (values id nil))
            (if (consp id)
                (values (car id) (cdr id))
                (values id nil))

-         (push `(defconstant ,(symbolicate prefix root suffix)
+         (push `(def!constant ,(symbolicate prefix root suffix)

                   ,(+ start (* step index))
                   ,@docs)
                results)))
                   ,(+ start (* step index))
                   ,@docs)
                results)))

@@ -237,48 +289,47 @@
 ;;; 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
 ;;; 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)
 (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)))))))
+  `(def!constant ,symbol
+     (%defconstant-eqx-value ',symbol ,expr ,eqx)
+     ,@(when doc (list doc))))
+(defun %defconstant-eqx-value (symbol expr eqx)
+  (declare (type function 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)))))
+\f
+;;; a helper function for various macros which expect clauses of a
+;;; given length, etc.
+;;;
+;;; 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))
+  ;; FIXME: 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.
+  (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)))