X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=9f3bf28a7a478eaef9f64f29220029a4035c0874;hb=8c6e2e85859766d2c4c6a272b952de2ebe467487;hp=6642fc29c9c249bff0411eba3c2313b902adfd78;hpb=ef5fdd6fc577298d1cef8eb97de5f577e30dd642;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 6642fc2..9f3bf28 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 - "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." @@ -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)) @@ -362,17 +360,18 @@ evaluated as a PROGN." ;; var. (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (let* ((n-list (gensym "N-LIST")) - (start (gensym "START")) - (tmp (gensym "TMP"))) + (start (gensym "START"))) (multiple-value-bind (clist members clist-ok) (cond ((sb!xc:constantp list env) (let ((value (constant-form-value list env))) - (multiple-value-bind (all dot) (list-members value) - (when dot + (multiple-value-bind (all dot) (list-members value :max-length 20) + (when (eql dot t) ;; Full warning is too much: the user may terminate the loop ;; early enough. Contents are still right, though. (style-warn "Dotted list ~S in DOLIST." value)) - (values value all t)))) + (if (eql dot :maybe) + (values value nil nil) + (values value all t))))) ((and (consp list) (eq 'list (car list)) (every (lambda (arg) (sb!xc:constantp arg env)) (cdr list))) (let ((values (mapcar (lambda (arg) (constant-form-value arg env)) (cdr list)))) @@ -384,10 +383,9 @@ evaluated as a PROGN." (tagbody ,start (unless (endp ,n-list) - (let* (,@(if clist-ok - `((,tmp (truly-the (member ,@members) (car ,n-list))) - (,var ,tmp)) - `((,var (car ,n-list))))) + (let ((,var ,(if clist-ok + `(truly-the (member ,@members) (car ,n-list)) + `(car ,n-list)))) ,@decls (setq ,n-list (cdr ,n-list)) (tagbody ,@forms)) @@ -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)) @@ -548,6 +549,7 @@ evaluated as a PROGN." clauses)))) `(block ,block-tag (let ((,temp-var nil)) + (declare (ignorable ,temp-var)) (tagbody (restart-bind ,(mapcar (lambda (datum) @@ -617,6 +619,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 +662,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 +670,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 +686,7 @@ specification." (list type `(lambda (temp) ,(if ll - `(setf ,var temp) + `(setf (cdr ,cell) temp) '(declare (ignore temp))) (go ,tag))))) annotated-cases) @@ -689,7 +698,7 @@ specification." (list tag `(return-from ,block ,(if ll - `(,fun-name ,var) + `(,fun-name (cdr ,cell)) `(,fun-name)))))) annotated-cases))))))))))