X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=2285b4f6e704e74d3d0152dd9b0fb98475f27cf1;hb=625c9493a8a7b5186144d21302437cf4f4f3571c;hp=0df13b61e51aa501507a0967416ba9fed55ef59d;hpb=e082422c19768dd7d6e30126740fe7f05cbd603a;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 0df13b6..2285b4f 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -41,7 +41,7 @@ (if (= (length vars) 1) `(let ((,(car vars) ,value-form)) ,@body) - (let ((ignore (gensym))) + (let ((ignore (sb!xc:gensym))) `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars) &rest ,ignore) (declare (ignore ,ignore)) @@ -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))) @@ -146,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)) @@ -218,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 - "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." @@ -331,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)) @@ -445,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)))) @@ -500,7 +504,7 @@ evaluated as a PROGN." (k '() (list* (cadr l) (car l) k))) ((or (null l) (not (member (car l) keys))) (values (nreverse k) l))))) - (let ((block-tag (gensym)) + (let ((block-tag (sb!xc:gensym "BLOCK")) (temp-var (gensym)) (data (macrolet (;; KLUDGE: This started as an old DEFMACRO @@ -529,11 +533,14 @@ 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)) (list (car clause) ;name=0 - (gensym) ;tag=1 + (sb!xc:gensym "TAG") ;tag=1 (transform-keywords :report report ;keywords=2 :interactive interactive :test test) @@ -601,7 +608,7 @@ evaluated as a PROGN." (and (consp x) (eq 'lambda (car x)) (setf lambda-form x)))))) - (let ((name (gensym "LAMBDA"))) + (let ((name (sb!xc:gensym "LAMBDA"))) (push `(,name ,@(cdr lambda-form)) local-funs) (list type `(function ,name))) binding)))) @@ -611,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))))) @@ -646,14 +654,14 @@ specification." (handler-case (return-from ,normal-return ,form) ,@(remove no-error-clause cases))))))) (let* ((local-funs nil) - (annotated-cases (mapcar (lambda (case) - (let ((tag (gensym "TAG")) - (fun (gensym "FUN"))) - (destructuring-bind (type ll &body body) case - (push `(,fun ,ll ,@body) local-funs) - (list tag type ll fun)))) - cases))) - (with-unique-names (block var form-fun) + (annotated-cases + (mapcar (lambda (case) + (with-unique-names (tag fun) + (destructuring-bind (type ll &body body) case + (push `(,fun ,ll ,@body) local-funs) + (list tag type ll fun)))) + cases))) + (with-unique-names (block cell form-fun) `(dx-flet ((,form-fun () #!-x86 ,form ;; Need to catch FP errors here! @@ -661,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) @@ -671,7 +685,7 @@ specification." (list type `(lambda (temp) ,(if ll - `(setf ,var temp) + `(setf (cdr ,cell) temp) '(declare (ignore temp))) (go ,tag))))) annotated-cases) @@ -683,7 +697,7 @@ specification." (list tag `(return-from ,block ,(if ll - `(,fun-name ,var) + `(,fun-name (cdr ,cell)) `(,fun-name)))))) annotated-cases))))))))))