0.8.16.2: TYPE-ERROR for ERROR

[sbcl.git] / src / code / defboot.lisp

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index f05fb0a..964639f 100644 (file)
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -40,7 +40,8 @@
       `(let ((,(car vars) ,value-form))
         ,@body)
       (let ((ignore (gensym)))
       `(let ((,(car vars) ,value-form))
         ,@body)
       (let ((ignore (gensym)))

-       `(multiple-value-call #'(lambda (&optional ,@vars &rest ,ignore)
+       `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars)
+                                        &rest ,ignore)

                                  (declare (ignore ,ignore))
                                  ,@body)
                              ,value-form)))
                                  (declare (ignore ,ignore))
                                  ,@body)
                              ,value-form)))

@@ -151,7 +152,7 @@
   "Define a function at top level."
   #+sb-xc-host
   (unless (symbol-package (fun-name-block-name name))
   "Define a function at top level."
   #+sb-xc-host
   (unless (symbol-package (fun-name-block-name name))

-    (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name))
+    (warn "DEFUN of uninterned function name ~S (tricky for GENESIS)" name))

   (multiple-value-bind (forms decls doc) (parse-body body)
     (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA
           (lambda-guts `(,args
   (multiple-value-bind (forms decls doc) (parse-body body)
     (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA
           (lambda-guts `(,args

@@ -159,7 +160,7 @@
                          (block ,(fun-name-block-name name)
                            ,@forms)))
           (lambda `(lambda ,@lambda-guts))
                          (block ,(fun-name-block-name name)
                            ,@forms)))
           (lambda `(lambda ,@lambda-guts))

-           #-sb-xc-host
+          #-sb-xc-host

           (named-lambda `(named-lambda ,name ,@lambda-guts))
           (inline-lambda
            (when (inline-fun-name-p name)
           (named-lambda `(named-lambda ,name ,@lambda-guts))
           (inline-lambda
            (when (inline-fun-name-p name)

@@ -172,9 +173,8 @@
                     name)
                    nil)))))
       `(progn
                     name)
                    nil)))))
       `(progn

-
-        ;; In cross-compilation of toplevel DEFUNs, we arrange
-        ;; for the LAMBDA to be statically linked by GENESIS.
+        ;; In cross-compilation of toplevel DEFUNs, we arrange for
+        ;; the LAMBDA to be statically linked by GENESIS.

         ;;
         ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
         ;; here instead of LAMBDA. The reason is historical:
         ;;
         ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
         ;; here instead of LAMBDA. The reason is historical:

@@ -183,22 +183,25 @@
         #+sb-xc-host
         (cold-fset ,name ,lambda)
 
         #+sb-xc-host
         (cold-fset ,name ,lambda)
 

-        (eval-when (:compile-toplevel :load-toplevel :execute)
-          (sb!c:%compiler-defun ',name ',inline-lambda))
-
-        (%defun ',name
-                ;; In normal compilation (not for cold load) this is
-                ;; where the compiled LAMBDA first appears. In
-                ;; cross-compilation, we manipulate the
-                ;; previously-statically-linked LAMBDA here.
-                #-sb-xc-host ,named-lambda
-                #+sb-xc-host (fdefinition ',name)
-                ,doc)))))
+        (eval-when (:compile-toplevel)
+          (sb!c:%compiler-defun ',name ',inline-lambda t))
+        (eval-when (:load-toplevel :execute)
+          (%defun ',name
+                  ;; In normal compilation (not for cold load) this is
+                  ;; where the compiled LAMBDA first appears. In
+                  ;; cross-compilation, we manipulate the
+                  ;; previously-statically-linked LAMBDA here.
+                  #-sb-xc-host ,named-lambda
+                  #+sb-xc-host (fdefinition ',name)
+                  ,doc
+                  ',inline-lambda))))))
+

 #-sb-xc-host
 #-sb-xc-host

-(defun %defun (name def doc)
+(defun %defun (name def doc inline-lambda)

   (declare (type function def))
   (declare (type (or null simple-string) doc))
   (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN
   (declare (type function def))
   (declare (type (or null simple-string) doc))
   (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN

+  (sb!c:%compiler-defun name inline-lambda nil)

   (when (fboundp name)
     (/show0 "redefining NAME in %DEFUN")
     (style-warn "redefining ~S in DEFUN" name))
   (when (fboundp name)
     (/show0 "redefining NAME in %DEFUN")
     (style-warn "redefining ~S in DEFUN" name))

@@ -209,7 +212,7 @@
   ;; something sane, (1) doing so doesn't really fix the bug, and 
   ;; (2) doing probably isn't even really safe.
   #+nil (setf (%fun-name def) name)
   ;; something sane, (1) doing so doesn't really fix the bug, and 
   ;; (2) doing probably isn't even really safe.
   #+nil (setf (%fun-name def) name)

-
+  

   (when doc
     (setf (fdocumentation name 'function) doc))
   name)
   (when doc
     (setf (fdocumentation name 'function) doc))
   name)

@@ -223,13 +226,10 @@
   value, the old value is not clobbered. The third argument is an optional
   documentation string for the variable."
   `(progn
   value, the old value is not clobbered. The third argument is an optional
   documentation string for the variable."
   `(progn

-     (declaim (special ,var))
-     ,@(when valp
-        `((unless (boundp ',var)
-            (set ',var ,val))))
-     ,@(when docp
-        `((setf (fdocumentation ',var 'variable) ',doc )))
-     ',var))
+     (eval-when (:compile-toplevel)
+       (%compiler-defvar ',var))
+     (eval-when (:load-toplevel :execute)
+       (%defvar ',var (unless (boundp ',var) ,val) ',valp ,doc ',docp))))

 
 (defmacro-mundanely defparameter (var val &optional (doc nil docp))
   #!+sb-doc
 
 (defmacro-mundanely defparameter (var val &optional (doc nil docp))
   #!+sb-doc

@@ -239,11 +239,31 @@
   previous value. The third argument is an optional documentation
   string for the parameter."
   `(progn
   previous value. The third argument is an optional documentation
   string for the parameter."
   `(progn

-     (declaim (special ,var))
-     (set ',var ,val)
-     ,@(when docp
-        `((setf (fdocumentation ',var 'variable) ',doc)))
-     ',var))
+     (eval-when (:compile-toplevel)
+       (%compiler-defvar ',var))
+     (eval-when (:load-toplevel :execute)
+       (%defparameter ',var ,val ,doc ',docp))))
+
+(defun %compiler-defvar (var)
+  (sb!xc:proclaim `(special ,var)))
+
+#-sb-xc-host
+(defun %defvar (var val valp doc docp)
+  (%compiler-defvar var)
+  (when valp
+    (unless (boundp var)
+      (set var val)))
+  (when docp
+    (setf (fdocumentation var 'variable) doc))
+  var)
+
+#-sb-xc-host
+(defun %defparameter (var val doc docp)
+  (%compiler-defvar var)
+  (set var val)
+  (when docp
+    (setf (fdocumentation var 'variable) doc))
+  var)

 \f
 ;;;; iteration constructs
 
 \f
 ;;;; iteration constructs
 

@@ -584,10 +604,8 @@
                                        `(let ((,(caaddr annotated-case)
                                                ,var))
                                           ,@body))
                                        `(let ((,(caaddr annotated-case)
                                                ,var))
                                           ,@body))

-                                      ((not (cdr body))
-                                       (car body))

                                       (t
                                       (t

-                                       `(progn ,@body)))))))
+                                       `(locally ,@body)))))))

                   annotated-cases))))))))
 \f
 ;;;; miscellaneous
                   annotated-cases))))))))
 \f
 ;;;; miscellaneous

@@ -634,8 +652,11 @@
                        ;; functions appearing in fundamental defining
                        ;; macro expansions:
                        %compiler-deftype
                        ;; functions appearing in fundamental defining
                        ;; macro expansions:
                        %compiler-deftype

+                       %compiler-defvar

                        %defun
                        %defsetf
                        %defun
                        %defsetf

+                       %defparameter
+                       %defvar

                        sb!c:%compiler-defun
                        sb!c::%define-symbol-macro
                        sb!c::%defconstant
                        sb!c:%compiler-defun
                        sb!c::%define-symbol-macro
                        sb!c::%defconstant