0.7.6.20:

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

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index f19daae..75ec633 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -13,18 +13,6 @@
 
 (in-package "SB!IMPL")
 
 
 (in-package "SB!IMPL")
 

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

 ;;; something not EQ to anything we might legitimately READ
 (defparameter *eof-object* (make-symbol "EOF-OBJECT"))
 
 ;;; something not EQ to anything we might legitimately READ
 (defparameter *eof-object* (make-symbol "EOF-OBJECT"))
 

@@ -48,10 +36,43 @@
 ;;; index leaving the loop range)
 (def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
 
 ;;; index leaving the loop range)
 (def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
 

+;;; A couple of VM-related types that are currently used only on the
+;;; alpha platform. -- CSR, 2002-06-24
+(def!type unsigned-byte-with-a-bite-out (s bite)
+  (cond ((eq s '*) 'integer)
+        ((and (integerp s) (> s 1))
+         (let ((bound (ash 1 s)))
+           `(integer 0 ,(- bound bite 1))))
+        (t
+         (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+
+(def!type load/store-index (scale lowtag min-offset
+                                &optional (max-offset min-offset))
+  `(integer ,(- (truncate (+ (ash 1 16)
+                            (* min-offset sb!vm:n-word-bytes)
+                            (- lowtag))
+                         scale))
+           ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+                         (* max-offset sb!vm:n-word-bytes))
+                      scale)))
+

 ;;; the default value used for initializing character data. The ANSI
 ;;; the default value used for initializing character data. The ANSI

-;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
-;;; because it's not in the ANSI table of portable characters.
-(defconstant default-init-char #\space)
+;;; spec says this is arbitrary, so we use the value that falls
+;;; through when we just let the low-level consing code initialize
+;;; all newly-allocated memory to zero.
+;;;
+;;; KLUDGE: It might be nice to use something which is a
+;;; STANDARD-CHAR, both to reduce user surprise a little and, probably
+;;; more significantly, to help SBCL's cross-compiler (which knows how
+;;; to dump STANDARD-CHARs). Unfortunately, the old CMU CL code is
+;;; shot through with implicit assumptions that it's #\NULL, and code
+;;; in several places (notably both DEFUN MAKE-ARRAY and DEFTRANSFORM
+;;; MAKE-ARRAY) would have to be rewritten. -- WHN 2001-10-04
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; an expression we can use to construct a DEFAULT-INIT-CHAR value
+  ;; at load time (so that we don't need to teach the cross-compiler
+  ;; how to represent and dump non-STANDARD-CHARs like #\NULL)
+  (defparameter *default-init-char-form* '(code-char 0)))

 
 ;;; CHAR-CODE values for ASCII characters which we care about but
 ;;; which aren't defined in section "2.1.3 Standard Characters" of the
 
 ;;; CHAR-CODE values for ASCII characters which we care about but
 ;;; which aren't defined in section "2.1.3 Standard Characters" of the

@@ -64,12 +85,14 @@
 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
 ;;; (or just find a nicer way of expressing characters portably?) --
 ;;; WHN 19990713
 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
 ;;; (or just find a nicer way of expressing characters portably?) --
 ;;; WHN 19990713

-(defconstant bell-char-code 7)
-(defconstant tab-char-code 9)
-(defconstant form-feed-char-code 12)
-(defconstant return-char-code 13)
-(defconstant escape-char-code 27)
-(defconstant rubout-char-code 127)
+(def!constant bell-char-code 7)
+(def!constant backspace-char-code 8)
+(def!constant tab-char-code 9)
+(def!constant line-feed-char-code 10)
+(def!constant form-feed-char-code 12)
+(def!constant return-char-code 13)
+(def!constant escape-char-code 27)
+(def!constant rubout-char-code 127)

 \f
 ;;;; type-ish predicates
 
 \f
 ;;;; type-ish predicates
 

@@ -96,8 +119,8 @@
                                         (1- max))))
          (t nil))))
 
                                         (1- max))))
          (t nil))))
 

-;;; Is X a circular list?
-(defun circular-list-p (x)
+;;; Is X a list containing a cycle?
+(defun cyclic-list-p (x)

   (and (listp x)
        (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x)))) 
         (do ((y x (safe-cddr y))
   (and (listp x)
        (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x)))) 
         (do ((y x (safe-cddr y))

@@ -132,6 +155,13 @@
               ((or (= r 0) (> d q)) (/= r 0))
             (declare (fixnum inc))
             (multiple-value-setq (q r) (truncate x d))))))
               ((or (= r 0) (> d q)) (/= r 0))
             (declare (fixnum inc))
             (multiple-value-setq (q r) (truncate x d))))))

+
+;;; Could this object contain other objects? (This is important to
+;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
+(defun compound-object-p (x)
+  (or (consp x)
+      (typep x 'instance)
+      (typep x '(array t *))))

 \f
 ;;;; the COLLECT macro
 ;;;;
 \f
 ;;;; the COLLECT macro
 ;;;;

@@ -179,7 +209,7 @@
 ;;; the function is made the new value for the collection. As a
 ;;; totally magical special-case, FUNCTION may be COLLECT, which tells
 ;;; us to build a list in forward order; this is the default. If an
 ;;; the function is made the new value for the collection. As a
 ;;; totally magical special-case, FUNCTION may be COLLECT, which tells
 ;;; us to build a list in forward order; this is the default. If an

-;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd
+;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd

 ;;; onto the end. Note that FUNCTION may be anything that can appear
 ;;; in the functional position, including macros and lambdas.
 (defmacro collect (collections &body body)
 ;;; onto the end. Note that FUNCTION may be anything that can appear
 ;;; in the functional position, including macros and lambdas.
 (defmacro collect (collections &body body)

@@ -187,7 +217,7 @@
        (binds ()))
     (dolist (spec collections)
       (unless (proper-list-of-length-p spec 1 3)
        (binds ()))
     (dolist (spec collections)
       (unless (proper-list-of-length-p spec 1 3)

-       (error "malformed collection specifier: ~S." spec))
+       (error "malformed collection specifier: ~S" spec))

       (let* ((name (first spec))
             (default (second spec))
             (kind (or (third spec) 'collect))
       (let* ((name (first spec))
             (default (second spec))
             (kind (or (third spec) 'collect))

@@ -218,7 +248,7 @@
 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
 (defun memq (item list)
   #!+sb-doc
 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
 (defun memq (item list)
   #!+sb-doc

-  "Returns tail of LIST beginning with first element EQ to ITEM."
+  "Return tail of LIST beginning with first element EQ to ITEM."

   ;; KLUDGE: These could be and probably should be defined as
   ;;   (MEMBER ITEM LIST :TEST #'EQ)),
   ;; but when I try to cross-compile that, I get an error from
   ;; KLUDGE: These could be and probably should be defined as
   ;;   (MEMBER ITEM LIST :TEST #'EQ)),
   ;; but when I try to cross-compile that, I get an error from

@@ -275,6 +305,15 @@
 (declaim (inline neq))
 (defun neq (x y)
   (not (eq x y)))
 (declaim (inline neq))
 (defun neq (x y)
   (not (eq x y)))

+
+;;; not really an old-fashioned function, but what the calling
+;;; convention should've been: like NTH, but with the same argument
+;;; order as in all the other dereferencing functions, with the
+;;; collection first and the index second
+(declaim (inline nth-but-with-sane-arg-order))
+(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
+(defun nth-but-with-sane-arg-order (list index)
+  (nth index list))

 \f
 ;;;; miscellaneous iteration extensions
 
 \f
 ;;;; miscellaneous iteration extensions
 

@@ -357,7 +396,7 @@
 ;;;   The code for initializing the cache is wrapped in a form with
 ;;;   the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
 ;;;   in type system definitions so that caches will be created
 ;;;   The code for initializing the cache is wrapped in a form with
 ;;;   the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
 ;;;   in type system definitions so that caches will be created

-;;;   before top-level forms run.)
+;;;   before top level forms run.)

 (defmacro define-hash-cache (name args &key hash-function hash-bits default
                                  (init-wrapper 'progn)
                                  (values 1))
 (defmacro define-hash-cache (name args &key hash-function hash-bits default
                                  (init-wrapper 'progn)
                                  (values 1))

@@ -373,7 +412,7 @@
         (n-cache (gensym)))
 
     (unless (= (length default-values) values)
         (n-cache (gensym)))
 
     (unless (= (length default-values) values)

-      (error "The number of default values ~S differs from :VALUES ~D."
+      (error "The number of default values ~S differs from :VALUES ~W."

             default values))
 
     (collect ((inlines)
             default values))
 
     (collect ((inlines)

@@ -432,8 +471,8 @@
                  (,n-cache ,var-name))
              (declare (type fixnum ,n-index))
              ,@(sets)
                  (,n-cache ,var-name))
              (declare (type fixnum ,n-index))
              ,@(sets)

-             ,@(mapcar #'(lambda (i val)
-                           `(setf (svref ,n-cache ,i) ,val))
+             ,@(mapcar (lambda (i val)
+                         `(setf (svref ,n-cache ,i) ,val))

                        (values-indices)
                        (values-names))
              (values)))))
                        (values-indices)
                        (values-names))
              (values)))))

@@ -449,8 +488,8 @@
                  (dotimes (i nargs)
                    (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
                  (arg-sets))
                  (dotimes (i nargs)
                    (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
                  (arg-sets))

-             ,@(mapcar #'(lambda (i val)
-                           `(setf (svref ,n-cache ,i) ,val))
+             ,@(mapcar (lambda (i val)
+                         `(setf (svref ,n-cache ,i) ,val))

                        (values-indices)
                        default-values))
            (values)))
                        (values-indices)
                        default-values))
            (values)))

@@ -541,7 +580,7 @@
 ;;;; various operations on names
 
 ;;; Is NAME a legal function name?
 ;;;; various operations on names
 
 ;;; Is NAME a legal function name?

-(defun legal-function-name-p (name)
+(defun legal-fun-name-p (name)

   (or (symbolp name)
       (and (consp name)
            (eq (car name) 'setf)
   (or (symbolp name)
       (and (consp name)
            (eq (car name) 'setf)

@@ -549,18 +588,27 @@
            (symbolp (cadr name))
            (null (cddr name)))))
 
            (symbolp (cadr name))
            (null (cddr name)))))
 

+;;; Signal an error unless NAME is a legal function name.
+(defun legal-fun-name-or-type-error (name)
+  (unless (legal-fun-name-p name)
+    (error 'simple-type-error
+          :datum name
+          :expected-type '(or symbol list)
+          :format-control "invalid function name: ~S"
+          :format-arguments (list name))))
+

 ;;; Given a function name, return the name for the BLOCK which
 ;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
 ;;; Given a function name, return the name for the BLOCK which
 ;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).

-(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
-(defun function-name-block-name (function-name)
-  (cond ((symbolp function-name)
-        function-name)
-       ((and (consp function-name)
-             (= (length function-name) 2)
-             (eq (first function-name) 'setf))
-        (second function-name))
+(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name))
+(defun fun-name-block-name (fun-name)
+  (cond ((symbolp fun-name)
+        fun-name)
+       ((and (consp fun-name)
+             (= (length fun-name) 2)
+             (eq (first fun-name) 'setf))
+        (second fun-name))

        (t
        (t

-        (error "not legal as a function name: ~S" function-name))))
+        (error "not legal as a function name: ~S" fun-name))))

 
 (defun looks-like-name-of-special-var-p (x)
   (and (symbolp x)
 
 (defun looks-like-name-of-special-var-p (x)
   (and (symbolp x)

@@ -569,29 +617,40 @@
              (char= #\* (aref name 0))
              (char= #\* (aref name (1- (length name))))))))
 
              (char= #\* (aref name 0))
              (char= #\* (aref name (1- (length name))))))))
 

-;;; 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)
+;;; Some symbols are defined by ANSI to be self-evaluating. Return
+;;; non-NIL for such symbols (and make the non-NIL value a traditional
+;;; message, for use in contexts where the user asks us to change such
+;;; a symbol).
+(defun symbol-self-evaluating-p (symbol)

   (declare (type symbol symbol))
   (cond ((eq symbol t)
   (declare (type symbol symbol))
   (cond ((eq symbol t)

-        (error "Veritas aeterna. (can't change T)"))
+        "Veritas aeterna. (can't change T)")

        ((eq symbol nil)
        ((eq symbol nil)

-        (error "Nihil ex nihil. (can't change NIL)"))
+        "Nihil ex nihil. (can't change NIL)")

        ((keywordp symbol)
        ((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.)
-       ))
+        "Keyword values can't be changed.")
+       (t
+        nil)))
+
+;;; This function is to be called just before a change which would
+;;; affect the symbol value. (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-value (symbol)
+  (declare (type symbol symbol))
+  (let ((reason (symbol-self-evaluating-p symbol)))
+    (when reason
+      (error reason)))
+  ;; (Note: 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.)
+  (values))
+

 
 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
 
 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary

-;;; assignment. That way things like
+;;; assignment instead of doing cold static linking. That way things like

 ;;;   (FLET ((FROB (X) ..))
 ;;;     (DEFUN FOO (X Y) (FROB X) ..)
 ;;;     (DEFUN BAR (Z) (AND (FROB X) ..)))
 ;;;   (FLET ((FROB (X) ..))
 ;;;     (DEFUN FOO (X Y) (FROB X) ..)
 ;;;     (DEFUN BAR (Z) (AND (FROB X) ..)))

@@ -604,7 +663,12 @@
    "~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
 (SETF FDEFINITION)~:@>"
    name)
    "~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
 (SETF FDEFINITION)~:@>"
    name)

-  `(setf (fdefinition ',name) ,lambda))
+  ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA
+  ;; expression so that the compiler can use NAME in debug names etc. 
+  (destructuring-bind (lambda-symbol &rest lambda-rest) lambda
+    (assert (eql lambda-symbol 'lambda)) ; else dunno how to do conversion
+    `(setf (fdefinition ',name)
+           (named-lambda ,name ,@lambda-rest))))

 \f
 ;;;; ONCE-ONLY
 ;;;;
 \f
 ;;;; ONCE-ONLY
 ;;;;

@@ -648,10 +712,10 @@
 ;;; error indicating that a required &KEY argument was not supplied.
 ;;; This function is also useful for DEFSTRUCT slot defaults
 ;;; corresponding to required arguments.
 ;;; error indicating that a required &KEY argument was not supplied.
 ;;; This function is also useful for DEFSTRUCT slot defaults
 ;;; corresponding to required arguments.

-(declaim (ftype (function () nil) required-argument))
-(defun required-argument ()
+(declaim (ftype (function () nil) missing-arg))
+(defun missing-arg ()

   #!+sb-doc
   #!+sb-doc

-  (/show0 "entering REQUIRED-ARGUMENT")
+  (/show0 "entering MISSING-ARG")

   (error "A required &KEY or &OPTIONAL argument was not supplied."))
 
 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
   (error "A required &KEY or &OPTIONAL argument was not supplied."))
 
 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight

@@ -665,16 +729,40 @@
 ;;; guts of complex systems anyway, I replaced it too.)
 (defmacro aver (expr)
   `(unless ,expr
 ;;; guts of complex systems anyway, I replaced it too.)
 (defmacro aver (expr)
   `(unless ,expr

-     (%failed-aver ,(let ((*package* (find-package :keyword)))
-                     (format nil "~S" expr)))))
+     (%failed-aver ,(format nil "~A" expr))))
+

 (defun %failed-aver (expr-as-string)
 (defun %failed-aver (expr-as-string)

-  (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
+  (bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
+
+;;; We need a definition of BUG here for the host compiler to be able
+;;; to deal with BUGs in sbcl. This should never affect an end-user,
+;;; who will pick up the definition that signals a CONDITION of
+;;; condition-class BUG; however, this is not defined on the host
+;;; lisp, but for the target. SBCL developers sometimes trigger BUGs
+;;; in their efforts, and it is useful to get the details of the BUG
+;;; rather than an undefined function error. - CSR, 2002-04-12
+#+sb-xc-host
+(defun bug (format-control &rest format-arguments)
+  (error 'simple-error
+        :format-control "~@<  ~? ~:@_~?~:>"
+        :format-arguments `(,format-control
+                            ,format-arguments
+                            "~@<If you see this and are an SBCL ~
+developer, then it is probable that you have made a change to the ~
+system that has broken the ability for SBCL to compile, usually by ~
+removing an assumed invariant of the system, but sometimes by making ~
+an averrance that is violated (check your code!). If you are a user, ~
+please submit a bug report to the developers' mailing list, details of ~
+which can be found at <http://sbcl.sourceforge.net/>.~:@>"
+                            ())))
+

 (defmacro enforce-type (value type)
   (once-only ((value value))
     `(unless (typep ,value ',type)
        (%failed-enforce-type ,value ',type))))
 (defmacro enforce-type (value type)
   (once-only ((value value))
     `(unless (typep ,value ',type)
        (%failed-enforce-type ,value ',type))))

+

 (defun %failed-enforce-type (value type)
 (defun %failed-enforce-type (value type)

-  (error 'simple-type-error
+  (error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG?

         :value value
         :expected-type type
         :format-string "~@<~S ~_is not a ~_~S~:>"
         :value value
         :expected-type type
         :format-string "~@<~S ~_is not a ~_~S~:>"

@@ -899,7 +987,6 @@
                       (t
                        (error "bad option: ~S" (first option)))))))))))
     `(def!method print-object ((structure ,name) ,stream)
                       (t
                        (error "bad option: ~S" (first option)))))))))))
     `(def!method print-object ((structure ,name) ,stream)

-       ;; FIXME: should probably be byte-compiled

        (pprint-logical-block (,stream nil)
         (print-unreadable-object (structure
                                   ,stream
        (pprint-logical-block (,stream nil)
         (print-unreadable-object (structure
                                   ,stream

@@ -914,3 +1001,8 @@
   (if (typep possibly-logical-pathname 'logical-pathname)
       (translate-logical-pathname possibly-logical-pathname)
       possibly-logical-pathname))
   (if (typep possibly-logical-pathname 'logical-pathname)
       (translate-logical-pathname possibly-logical-pathname)
       possibly-logical-pathname))

+
+(defun deprecation-warning (bad-name &optional good-name)
+  (warn "using deprecated ~S~@[, should use ~S instead~]"
+       bad-name
+       good-name))