X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=1e915ca4b5bc40dea3c389feafe274149b393686;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=ddd6355f9ca01e4a9bc923deeace5c6cd66d0673;hpb=5d04a95274c9ddaebbcd6ddffc5d646e2c25598c;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index ddd6355..1e915ca 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." @@ -320,7 +324,7 @@ evaluated as a PROGN." evaluated before each evaluation of the body Forms. When the Test is true, the Exit-Forms are evaluated as a PROGN, with the result being the value of the DO. A block named NIL is established around the entire expansion, - allowing RETURN to be used as an laternate exit mechanism." + allowing RETURN to be used as an alternate exit mechanism." (frob-do-body varlist endlist body 'let* 'setq 'do* nil)) ;;; DOTIMES and DOLIST could be defined more concisely using @@ -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)) @@ -345,7 +349,7 @@ evaluated as a PROGN." (type integer ,c)) ,@body))))) -(defmacro-mundanely dolist ((var list &optional (result nil)) &body body) +(defmacro-mundanely dolist ((var list &optional (result nil)) &body body &environment env) ;; We repeatedly bind the var instead of setting it so that we never ;; have to give the var an arbitrary value such as NIL (which might ;; conflict with a declaration). If there is a result form, we @@ -355,35 +359,56 @@ evaluated as a PROGN." ;; 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 "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)) - ;; Filter out TYPE declarations (VAR gets bound to NIL, - ;; and might have a conflicting type declaration) and - ;; IGNORE (VAR might be ignored in the loop body, but - ;; it's used in the result form). - ,@(filter-dolist-declarations decls) - ,var - ,result) - nil))))) + (let* ((n-list (gensym "N-LIST")) + (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 :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)) + (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)))) + (values values values t))) + (t + (values nil nil nil))) + `(block nil + (let ((,n-list ,(if clist-ok (list 'quote clist) list))) + (tagbody + ,start + (unless (endp ,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)) + (go ,start)))) + ,(if result + `(let ((,var nil)) + ;; Filter out TYPE declarations (VAR gets bound to NIL, + ;; and might have a conflicting type declaration) and + ;; IGNORE (VAR might be ignored in the loop body, but + ;; it's used in the result form). + ,@(filter-dolist-declarations decls) + ,var + ,result) + nil)))))) ;;;; conditions, handlers, restarts ;;; KLUDGE: we PROCLAIM these special here so that we can use restart ;;; macros in the compiler before the DEFVARs are compiled. -(sb!xc:proclaim - '(special *handler-clusters* *restart-clusters* *condition-restarts*)) +;;; +;;; For an explanation of these data structures, see DEFVARs in +;;; target-error.lisp. +(sb!xc:proclaim '(special *handler-clusters* *restart-clusters*)) (defmacro-mundanely with-condition-restarts (condition-form restarts-form &body body) @@ -392,41 +417,50 @@ evaluated as a PROGN." 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))) - `(let ((*condition-restarts* - (cons (let ((,n-cond ,condition-form)) - (cons ,n-cond - (append ,restarts-form - (cdr (assoc ,n-cond *condition-restarts*))))) - *condition-restarts*))) - ,@body))) + (once-only ((restarts restarts-form)) + (with-unique-names (restart) + ;; FIXME: check the need for interrupt-safety. + `(unwind-protect + (progn + (dolist (,restart ,restarts) + (push ,condition-form + (restart-associated-conditions ,restart))) + ,@body) + (dolist (,restart ,restarts) + (pop (restart-associated-conditions ,restart))))))) (defmacro-mundanely restart-bind (bindings &body forms) #!+sb-doc - "Executes forms in a dynamic context where the given restart bindings are - in effect. Users probably want to use RESTART-CASE. When clauses contain - the same restart name, FIND-RESTART will find the first such clause." - `(let ((*restart-clusters* - (cons (list - ,@(mapcar (lambda (binding) - (unless (or (car binding) - (member :report-function - binding - :test #'eq)) - (warn "Unnamed restart does not have a ~ - report function: ~S" - binding)) - `(make-restart :name ',(car binding) - :function ,(cadr binding) - ,@(cddr binding))) - bindings)) - *restart-clusters*))) - ,@forms)) + "(RESTART-BIND ({(case-name function {keyword value}*)}*) forms) + Executes forms in a dynamic context where the given bindings are in + effect. Users probably want to use RESTART-CASE. A case-name of NIL + indicates an anonymous restart. When bindings contain the same + restart name, FIND-RESTART will find the first such binding." + (flet ((parse-binding (binding) + (unless (>= (length binding) 2) + (error "ill-formed restart binding: ~S" binding)) + (destructuring-bind (name function + &key interactive-function + test-function + report-function) + binding + (unless (or name report-function) + (warn "Unnamed restart does not have a report function: ~ + ~S" binding)) + `(make-restart ',name ,function + ,report-function + ,interactive-function + ,@(and test-function + `(,test-function)))))) + `(let ((*restart-clusters* + (cons (list ,@(mapcar #'parse-binding bindings)) + *restart-clusters*))) + ,@forms))) ;;; 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)))) @@ -448,103 +482,97 @@ evaluated as a PROGN." expression)) expression))) -;;; FIXME: I did a fair amount of rearrangement of this code in order to -;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested.. (defmacro-mundanely restart-case (expression &body clauses &environment env) #!+sb-doc - "(RESTART-CASE form - {(case-name arg-list {keyword value}* body)}*) - The form is evaluated in a dynamic context where the clauses have special - meanings as points to which control may be transferred (see INVOKE-RESTART). - When clauses contain the same case-name, FIND-RESTART will find the first - such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or - macroexpands into such) then the signalled condition will be associated with - the new restarts." - (flet ((transform-keywords (&key report interactive test) - (let ((result '())) - (when report - (setq result (list* (if (stringp report) + "(RESTART-CASE form {(case-name arg-list {keyword value}* body)}*) + The form is evaluated in a dynamic context where the clauses have + special meanings as points to which control may be transferred (see + INVOKE-RESTART). When clauses contain the same case-name, + FIND-RESTART will find the first such clause. If form is a call to + SIGNAL, ERROR, CERROR or WARN (or macroexpands into such) then the + signalled condition will be associated with the new restarts." + ;; PARSE-CLAUSE (which uses PARSE-KEYWORDS-AND-BODY) is used to + ;; parse all clauses into lists of the form + ;; + ;; (NAME TAG KEYWORDS LAMBDA-LIST BODY) + ;; + ;; where KEYWORDS are suitable keywords for use in HANDLER-BIND + ;; bindings. These lists are then passed to + ;; * MAKE-BINDING which generates bindings for the respective NAME + ;; for HANDLER-BIND + ;; * MAKE-APPLY-AND-RETURN which generates TAGBODY entries executing + ;; the respective BODY. + (let ((block-tag (sb!xc:gensym "BLOCK")) + (temp-var (gensym))) + (labels ((parse-keywords-and-body (keywords-and-body) + (do ((form keywords-and-body (cddr form)) + (result '())) (nil) + (destructuring-bind (&optional key (arg nil argp) &rest rest) + form + (declare (ignore rest)) + (setq result + (append + (cond + ((and (eq key :report) argp) + (list :report-function + (if (stringp arg) `#'(lambda (stream) - (write-string ,report stream)) - `#',report) - :report-function - result))) - (when interactive - (setq result (list* `#',interactive - :interactive-function - result))) - (when test - (setq result (list* `#',test :test-function result))) - (nreverse result))) - (parse-keyword-pairs (list keys) - (do ((l list (cddr l)) - (k '() (list* (cadr l) (car l) k))) - ((or (null l) (not (member (car l) keys))) - (values (nreverse k) l))))) - (let ((block-tag (gensym)) - (temp-var (gensym)) - (data - (macrolet (;; KLUDGE: This started as an old DEFMACRO - ;; WITH-KEYWORD-PAIRS general utility, which was used - ;; only in this one place in the code. It was translated - ;; literally into this MACROLET in order to avoid some - ;; cross-compilation bootstrap problems. It would almost - ;; certainly be clearer, and it would certainly be more - ;; concise, to do a more idiomatic translation, merging - ;; this with the TRANSFORM-KEYWORDS logic above. - ;; -- WHN 19990925 - (with-keyword-pairs ((names expression) &body forms) - (let ((temp (member '&rest names))) - (unless (= (length temp) 2) - (error "&REST keyword is ~:[missing~;misplaced~]." - temp)) - (let* ((key-vars (ldiff names temp)) - (keywords (mapcar #'keywordicate key-vars)) - (key-var (gensym)) - (rest-var (cadr temp))) - `(multiple-value-bind (,key-var ,rest-var) - (parse-keyword-pairs ,expression ',keywords) - (let ,(mapcar (lambda (var keyword) - `(,var (getf ,key-var - ,keyword))) - key-vars keywords) - ,@forms)))))) - (mapcar (lambda (clause) - (with-keyword-pairs ((report interactive test - &rest forms) - (cddr clause)) - (list (car clause) ;name=0 - (gensym) ;tag=1 - (transform-keywords :report report ;keywords=2 - :interactive interactive - :test test) - (cadr clause) ;bvl=3 - forms))) ;body=4 - clauses)))) - `(block ,block-tag - (let ((,temp-var nil)) - (tagbody - (restart-bind - ,(mapcar (lambda (datum) - (let ((name (nth 0 datum)) - (tag (nth 1 datum)) - (keys (nth 2 datum))) - `(,name #'(lambda (&rest temp) - (setq ,temp-var temp) - (go ,tag)) - ,@keys))) - data) - (return-from ,block-tag - ,(munge-restart-case-expression expression env))) - ,@(mapcan (lambda (datum) - (let ((tag (nth 1 datum)) - (bvl (nth 3 datum)) - (body (nth 4 datum))) - (list tag - `(return-from ,block-tag - (apply (lambda ,bvl ,@body) - ,temp-var))))) - data))))))) + (write-string ,arg stream)) + `#',arg))) + ((and (eq key :interactive) argp) + (list :interactive-function `#',arg)) + ((and (eq key :test) argp) + (list :test-function `#',arg)) + (t + (return (values result form)))) + result))))) + (parse-clause (clause) + (unless (and (listp clause) (>= (length clause) 2) + (listp (second clause))) + (error "ill-formed ~S clause, no lambda-list:~% ~S" + 'restart-case clause)) + (destructuring-bind (name lambda-list &body body) clause + (multiple-value-bind (keywords body) + (parse-keywords-and-body body) + (list name (sb!xc:gensym "TAG") keywords lambda-list body)))) + (make-binding (clause-data) + (destructuring-bind (name tag keywords lambda-list body) clause-data + (declare (ignore body)) + `(,name + (lambda ,(cond ((null lambda-list) + ()) + ((and (null (cdr lambda-list)) + (not (member (car lambda-list) + '(&optional &key &aux)))) + '(temp)) + (t + '(&rest temp))) + ,@(when lambda-list `((setq ,temp-var temp))) + (locally (declare (optimize (safety 0))) + (go ,tag))) + ,@keywords))) + (make-apply-and-return (clause-data) + (destructuring-bind (name tag keywords lambda-list body) clause-data + (declare (ignore name keywords)) + `(,tag (return-from ,block-tag + ,(cond ((null lambda-list) + `(progn ,@body)) + ((and (null (cdr lambda-list)) + (not (member (car lambda-list) + '(&optional &key &aux)))) + `(funcall (lambda ,lambda-list ,@body) ,temp-var)) + (t + `(apply (lambda ,lambda-list ,@body) ,temp-var)))))))) + (let ((clauses-data (mapcar #'parse-clause clauses))) + `(block ,block-tag + (let ((,temp-var nil)) + (declare (ignorable ,temp-var)) + (tagbody + (restart-bind + ,(mapcar #'make-binding clauses-data) + (return-from ,block-tag + ,(munge-restart-case-expression expression env))) + ,@(mapcan #'make-apply-and-return clauses-data)))))))) (defmacro-mundanely with-simple-restart ((restart-name format-string &rest format-arguments) @@ -573,31 +601,28 @@ evaluated as a PROGN." (let* ((local-funs nil) (mapped-bindings (mapcar (lambda (binding) (destructuring-bind (type handler) binding - (let (lambda-form) + (let ((lambda-form handler)) (if (and (consp handler) - (or (prog1 (eq 'lambda (car handler)) - (setf lambda-form handler)) + (or (eq 'lambda (car handler)) (and (eq 'function (car handler)) (consp (cdr handler)) - (consp (cadr handler)) - (prog1 (eq 'lambda (caadr handler)) - (setf lambda-form (cadr handler))))) - ;; KLUDGE: DX-FLET doesn't handle non-required arguments yet. - (not (intersection (second lambda-form) sb!xc:lambda-list-keywords))) - (let ((name (gensym "LAMBDA"))) + (let ((x (second handler))) + (and (consp x) + (eq 'lambda (car x)) + (setf lambda-form x)))))) + (let ((name (sb!xc:gensym "LAMBDA"))) (push `(,name ,@(cdr lambda-form)) local-funs) (list type `(function ,name))) binding)))) - bindings)) - (form-fun (gensym "FORM-FUN"))) - `(dx-flet (,@(reverse local-funs) - (,form-fun () (progn ,form))) + bindings))) + `(dx-flet (,@(reverse local-funs)) (let ((*handler-clusters* (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) mapped-bindings)) *handler-clusters*))) - (declare (dynamic-extent *handler-clusters*)) - (,form-fun))))) + #!+stack-allocatable-fixed-objects + (declare (truly-dynamic-extent *handler-clusters*)) + (progn ,form))))) (defmacro-mundanely handler-bind (bindings &body forms) #!+sb-doc @@ -631,14 +656,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! @@ -646,8 +671,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) @@ -656,7 +687,7 @@ specification." (list type `(lambda (temp) ,(if ll - `(setf ,var temp) + `(setf (cdr ,cell) temp) '(declare (ignore temp))) (go ,tag))))) annotated-cases) @@ -668,7 +699,7 @@ specification." (list tag `(return-from ,block ,(if ll - `(,fun-name ,var) + `(,fun-name (cdr ,cell)) `(,fun-name)))))) annotated-cases))))))))))