X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=4147b0eabcd0b7f6b5c5ddf7c3c177e2ee42180d;hb=77d7fddb855305e783c100bfe9b6b46bdb05e4b6;hp=232802fce057a9c4b593f17013e82997d8001c48;hpb=6822034325136cde4e14773c83c3769b42721306;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 232802f..4147b0e 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))) @@ -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) ;;;; 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." @@ -345,7 +342,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,28 +352,47 @@ 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")) + (tmp (gensym "TMP"))) + (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 + ;; 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)))) + ((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* (,@(if clist-ok + `((,tmp (truly-the (member ,@members) (car ,n-list))) + (,var ,tmp)) + `((,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)))))) ;;;; conditions, handlers, restarts @@ -481,7 +497,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 @@ -514,7 +530,7 @@ evaluated as a PROGN." &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) @@ -582,7 +598,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)))) @@ -592,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))))) @@ -627,14 +644,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! @@ -642,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) @@ -652,7 +675,7 @@ specification." (list type `(lambda (temp) ,(if ll - `(setf ,var temp) + `(setf (cdr ,cell) temp) '(declare (ignore temp))) (go ,tag))))) annotated-cases) @@ -664,7 +687,7 @@ specification." (list tag `(return-from ,block ,(if ll - `(,fun-name ,var) + `(,fun-name (cdr ,cell)) `(,fun-name)))))) annotated-cases))))))))))