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 45d064c..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)))

@@ -105,19 +106,17 @@
 \f
 ;;;; various sequencing constructs
 
 \f
 ;;;; various sequencing constructs
 

-(defmacro-mundanely prog (varlist &body body-decls)
-  (multiple-value-bind (body decls) (parse-body body-decls nil)
-    `(block nil
-       (let ,varlist
-        ,@decls
-        (tagbody ,@body)))))
-
-(defmacro-mundanely prog* (varlist &body body-decls)
-  (multiple-value-bind (body decls) (parse-body body-decls nil)
-    `(block nil
-       (let* ,varlist
-        ,@decls
-        (tagbody ,@body)))))
+(flet ((prog-expansion-from-let (varlist body-decls let)
+         (multiple-value-bind (body decls)
+            (parse-body body-decls :doc-string-allowed nil)
+          `(block nil
+             (,let ,varlist
+               ,@decls
+               (tagbody ,@body))))))
+  (defmacro-mundanely prog (varlist &body body-decls)
+    (prog-expansion-from-let varlist body-decls 'let))
+  (defmacro-mundanely prog* (varlist &body body-decls)
+    (prog-expansion-from-let varlist body-decls 'let*)))

 
 (defmacro-mundanely prog1 (result &body body)
   (let ((n-result (gensym)))
 
 (defmacro-mundanely prog1 (result &body body)
   (let ((n-result (gensym)))

@@ -153,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

@@ -161,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)

@@ -169,14 +168,13 @@
              (or (sb!c:maybe-inline-syntactic-closure lambda env)
                  (progn
                    (#+sb-xc-host warn
              (or (sb!c:maybe-inline-syntactic-closure lambda env)
                  (progn
                    (#+sb-xc-host warn

-                    #-sb-xc-host sb!c:maybe-compiler-note
+                    #-sb-xc-host sb!c:maybe-compiler-notify

                     "lexical environment too hairy, can't inline DEFUN ~S"
                     name)
                    nil)))))
       `(progn
                     "lexical environment too hairy, can't inline DEFUN ~S"
                     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:

@@ -185,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))

@@ -211,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)

@@ -225,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

@@ -241,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
 

@@ -287,14 +305,14 @@
 (defmacro-mundanely dotimes ((var count &optional (result nil)) &body body)
   (cond ((numberp count)
         `(do ((,var 0 (1+ ,var)))
 (defmacro-mundanely dotimes ((var count &optional (result nil)) &body body)
   (cond ((numberp count)
         `(do ((,var 0 (1+ ,var)))

-          ((>= ,var ,count) ,result)
-          (declare (type unsigned-byte ,var))
-          ,@body))
+              ((>= ,var ,count) ,result)
+            (declare (type unsigned-byte ,var))
+            ,@body))

        (t (let ((v1 (gensym)))
             `(do ((,var 0 (1+ ,var)) (,v1 ,count))
        (t (let ((v1 (gensym)))
             `(do ((,var 0 (1+ ,var)) (,v1 ,count))

-              ((>= ,var ,v1) ,result)
-              (declare (type unsigned-byte ,var))
-              ,@body)))))
+                  ((>= ,var ,v1) ,result)
+                (declare (type unsigned-byte ,var))
+                ,@body)))))

 
 (defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
   ;; We repeatedly bind the var instead of setting it so that we never
 
 (defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
   ;; We repeatedly bind the var instead of setting it so that we never

@@ -305,19 +323,24 @@
   ;; environment. We spuriously reference the gratuitous variable,
   ;; since we don't want to use IGNORABLE on what might be a special
   ;; var.
   ;; environment. We spuriously reference the gratuitous variable,
   ;; since we don't want to use IGNORABLE on what might be a special
   ;; var.

-  (multiple-value-bind (forms decls) (parse-body body nil)
-    (let ((n-list (gensym)))
-      `(do* ((,n-list ,list (cdr ,n-list)))
-       ((endp ,n-list)
-        ,@(if result
-              `((let ((,var nil))
-                  ,var
-                  ,result))
-              '(nil)))
-       (let ((,var (car ,n-list)))
-         ,@decls
-         (tagbody
-            ,@forms))))))
+  (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+    (let ((n-list (gensym "N-LIST"))
+          (start (gensym "START")))
+      `(block nil
+         (let ((,n-list ,list))
+           (tagbody
+              ,start
+              (unless (endp ,n-list)
+                (let ((,var (car ,n-list)))
+                  ,@decls
+                  (setq ,n-list (cdr ,n-list))
+                  (tagbody ,@forms))
+                (go ,start))))
+         ,(if result
+              `(let ((,var nil))
+                 ,var
+                 ,result)
+               nil)))))

 \f
 ;;;; conditions, handlers, restarts
 
 \f
 ;;;; conditions, handlers, restarts
 

@@ -385,7 +408,7 @@
                     ,n-cond
                     (car *restart-clusters*)
                   ,(if (eq name 'cerror)
                     ,n-cond
                     (car *restart-clusters*)
                   ,(if (eq name 'cerror)

-                       `(cerror ,(second expression) ,n-cond)
+                       `(cerror ,(second exp) ,n-cond)

                        `(,name ,n-cond))))
              expression))
        expression)))
                        `(,name ,n-cond))))
              expression))
        expression)))

@@ -581,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

@@ -631,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