X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=2285b4f6e704e74d3d0152dd9b0fb98475f27cf1;hb=a6a12ed609d5467ec43b411283e5b3568fee81df;hp=c09818eb502edc358562017bb90517268eac53bb;hpb=79a8e51bf4b06a5bd57bc90233605f98fee3b041;p=sbcl.git

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index c09818e..2285b4f 100644
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -152,7 +152,8 @@ evaluated as a PROGN."
 (defun inline-fun-name-p (name)
   (or
    ;; the normal reason for saving the inline expansion
-   (info :function :inlinep name)
+   (let ((inlinep (info :function :inlinep name)))
+     (member inlinep '(:inline :maybe-inline)))
    ;; another reason for saving the inline expansion: If the
    ;; ANSI-recommended idiom
    ;;   (DECLAIM (INLINE FOO))
@@ -224,32 +225,29 @@ evaluated as a PROGN."
   (sb!c:%compiler-defun name inline-lambda nil)
   (when (fboundp name)
     (/show0 "redefining NAME in %DEFUN")
-    (style-warn 'sb!kernel::redefinition-with-defun :name name
-                :old (fdefinition name) :new def
-                :new-location source-location))
+    (warn 'sb!kernel::redefinition-with-defun
+          :name name
+          :new-function def
+          :new-location source-location))
   (setf (sb!xc:fdefinition name) def)
+  ;; %COMPILER-DEFUN doesn't do this except at compile-time, when it
+  ;; also checks package locks. By doing this here we let (SETF
+  ;; FDEFINITION) do the load-time package lock checking before
+  ;; we frob any existing inline expansions.
+  (sb!c::%set-inline-expansion name nil inline-lambda)
 
   (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)
 
 ;;;; DEFVAR and DEFPARAMETER
 
 (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
   #!+sb-doc
-  "Defines a special 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."
@@ -337,7 +335,7 @@ evaluated as a PROGN."
 ;;; ASAP, at the cost of being unable to use the standard
 ;;; destructuring mechanisms.
 (defmacro-mundanely dotimes ((var count &optional (result nil)) &body body)
-  (cond ((numberp count)
+  (cond ((integerp count)
         `(do ((,var 0 (1+ ,var)))
              ((>= ,var ,count) ,result)
            (declare (type unsigned-byte ,var))
@@ -451,7 +449,7 @@ evaluated as a PROGN."
 ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
 ;;; appropriate. Gross, but it's what the book seems to say...
 (defun munge-restart-case-expression (expression env)
-  (let ((exp (sb!xc:macroexpand expression env)))
+  (let ((exp (%macroexpand expression env)))
     (if (consp exp)
         (let* ((name (car exp))
                (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
@@ -535,6 +533,9 @@ evaluated as a PROGN."
                                              key-vars keywords)
                                  ,@forms))))))
              (mapcar (lambda (clause)
+                       (unless (listp (second clause))
+                         (error "Malformed ~S clause, no lambda-list:~%  ~S"
+                                'restart-case clause))
                        (with-keyword-pairs ((report interactive test
                                                     &rest forms)
                                             (cddr clause))
@@ -617,6 +618,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)))))
 
@@ -659,7 +661,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!
@@ -667,8 +669,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)
@@ -677,7 +685,7 @@ specification."
                                     (list type
                                           `(lambda (temp)
                                              ,(if ll
-                                                  `(setf ,var temp)
+                                                  `(setf (cdr ,cell) temp)
                                                   '(declare (ignore temp)))
                                              (go ,tag)))))
                                 annotated-cases)
@@ -689,7 +697,7 @@ specification."
                              (list tag
                                    `(return-from ,block
                                       ,(if ll
-                                           `(,fun-name ,var)
+                                           `(,fun-name (cdr ,cell))
                                            `(,fun-name))))))
                          annotated-cases))))))))))