1.0.32.12: Fix slot-value on specialized parameters in SVUC methods

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

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 581c994..4147b0e 100644 (file)
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -82,7 +82,9 @@
                            ,n-result
                            (cond ,@more))))
                   (if (eq t test)
-                      `(progn ,@forms)
+                      ;; THE to perserve non-toplevelness for FOO in
+                      ;;   (COND (T (FOO)))
+                      `(the t (progn ,@forms))
                       `(if ,test
                            (progn ,@forms)
                            ,(when more `(cond ,@more))))))))))
@@ -101,7 +103,9 @@ evaluated as a PROGN."
 
 (defmacro-mundanely and (&rest forms)
   (cond ((endp forms) t)
-        ((endp (rest forms)) (first forms))
+        ((endp (rest forms))
+         ;; Preserve non-toplevelness of the form!
+         `(the t ,(first forms)))
         (t
          `(if ,(first forms)
               (and ,@(rest forms))
@@ -109,7 +113,9 @@ evaluated as a PROGN."
 
 (defmacro-mundanely or (&rest forms)
   (cond ((endp forms) nil)
-        ((endp (rest forms)) (first forms))
+        ((endp (rest forms))
+         ;; Preserve non-toplevelness of the form!
+         `(the t ,(first forms)))
         (t
          (let ((n-result (gensym)))
            `(let ((,n-result ,(first forms)))
@@ -225,25 +231,16 @@ evaluated as a PROGN."
 
   (sb!c::note-name-defined name :function)
 
-  ;; FIXME: I want to do this here (and fix bug 137), but until the
-  ;; breathtaking CMU CL function name architecture is converted into
-  ;; 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)
-    #!+sb-eval
-    (when (typep def 'sb!eval:interpreted-function)
-      (setf (sb!eval:interpreted-function-documentation def)
-            doc)))
+    (setf (%fun-doc def) doc))
+
   name)
 \f
 ;;;; DEFVAR and DEFPARAMETER
 
 (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
   #!+sb-doc
-  "Define a global variable at top level. Declare the variable
+  "Define a special variable at top level. Declare the variable
   SPECIAL and, optionally, initialize it. If the variable already has a
   value, the old value is not clobbered. The third argument is an optional
   documentation string for the variable."
@@ -611,6 +608,7 @@ evaluated as a PROGN."
               (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
                                     mapped-bindings))
                     *handler-clusters*)))
+         #!+stack-allocatable-fixed-objects
          (declare (truly-dynamic-extent *handler-clusters*))
          (progn ,form)))))
 
@@ -653,7 +651,7 @@ specification."
                               (push `(,fun ,ll ,@body) local-funs)
                               (list tag type ll fun))))
                         cases)))
-          (with-unique-names (block var form-fun)
+          (with-unique-names (block cell form-fun)
             `(dx-flet ((,form-fun ()
                          #!-x86 ,form
                          ;; Need to catch FP errors here!
@@ -661,8 +659,14 @@ specification."
                        ,@(reverse local-funs))
                (declare (optimize (sb!c::check-tag-existence 0)))
                (block ,block
-                 (dx-let ((,var nil))
-                   (declare (ignorable ,var))
+                 ;; KLUDGE: We use a dx CONS cell instead of just assigning to
+                 ;; the variable directly, so that we can stack allocate
+                 ;; robustly: dx value cells don't work quite right, and it is
+                 ;; possible to construct user code that should loop
+                 ;; indefinitely, but instead eats up some stack each time
+                 ;; around.
+                 (dx-let ((,cell (cons :condition nil)))
+                   (declare (ignorable ,cell))
                    (tagbody
                       (%handler-bind
                        ,(mapcar (lambda (annotated-case)
@@ -671,7 +675,7 @@ specification."
                                     (list type
                                           `(lambda (temp)
                                              ,(if ll
-                                                  `(setf ,var temp)
+                                                  `(setf (cdr ,cell) temp)
                                                   '(declare (ignore temp)))
                                              (go ,tag)))))
                                 annotated-cases)
@@ -683,7 +687,7 @@ specification."
                              (list tag
                                    `(return-from ,block
                                       ,(if ll
-                                           `(,fun-name ,var)
+                                           `(,fun-name (cdr ,cell))
                                            `(,fun-name))))))
                          annotated-cases))))))))))
 \f