0.9.0.21:

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

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 2379081..8a8e9a3 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

@@ -172,33 +173,35 @@
                     name)
                    nil)))))
       `(progn
                     name)
                    nil)))))
       `(progn

-
-        ;; 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:
-        ;; COLD-FSET was written before NAMED-LAMBDA, and has special
-        ;; logic of its own to notify the compiler about NAME.
-        #+sb-xc-host
+        ;; 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:
+         ;; COLD-FSET was written before NAMED-LAMBDA, and has special
+         ;; logic of its own to notify the compiler about NAME.
+        #+sb-xc-host

         (cold-fset ,name ,lambda)
         (cold-fset ,name ,lambda)

+         
+        (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))))))

 
 

-        (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)))))

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

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

@@ -304,18 +324,23 @@
   ;; since we don't want to use IGNORABLE on what might be a special
   ;; var.
   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
   ;; since we don't want to use IGNORABLE on what might be a special
   ;; var.
   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed 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))))))
+    (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
 

@@ -327,9 +352,8 @@
 (defmacro-mundanely with-condition-restarts
     (condition-form restarts-form &body body)
   #!+sb-doc
 (defmacro-mundanely with-condition-restarts
     (condition-form restarts-form &body body)
   #!+sb-doc

-  "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
-   Evaluates the Forms in a dynamic environment where the restarts in the list
-   Restarts-Form are associated with the condition returned by Condition-Form.
+  "Evaluates the BODY in a dynamic environment where the restarts in the list
+   RESTARTS-FORM are associated with the condition returned by CONDITION-FORM.

    This allows FIND-RESTART, etc., to recognize restarts that are not related
    to the error currently being debugged. See also RESTART-CASE."
   (let ((n-cond (gensym)))
    This allows FIND-RESTART, etc., to recognize restarts that are not related
    to the error currently being debugged. See also RESTART-CASE."
   (let ((n-cond (gensym)))

@@ -354,7 +378,7 @@
                                                 binding
                                                 :test #'eq))
                               (warn "Unnamed restart does not have a ~
                                                 binding
                                                 :test #'eq))
                               (warn "Unnamed restart does not have a ~

-                                       report function: ~S"
+                                      report function: ~S"

                                     binding))
                             `(make-restart :name ',(car binding)
                                            :function ,(cadr binding)
                                     binding))
                             `(make-restart :name ',(car binding)
                                            :function ,(cadr binding)

@@ -383,7 +407,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)))

@@ -579,10 +603,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

@@ -629,8 +651,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