X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=0df13b61e51aa501507a0967416ba9fed55ef59d;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=9dc6d4616bbeb2fb85ec4b1d1b0c85e6b4a05555;hpb=07d11082f85d635148bfef93b3795b6c90dc7eca;p=sbcl.git diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 9dc6d46..0df13b6 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -69,7 +69,8 @@ (defmacro-mundanely cond (&rest clauses) (if (endp clauses) nil - (let ((clause (first clauses))) + (let ((clause (first clauses)) + (more (rest clauses))) (if (atom clause) (error "COND clause is not a list: ~S" clause) (let ((test (first clause)) @@ -79,22 +80,25 @@ `(let ((,n-result ,test)) (if ,n-result ,n-result - (cond ,@(rest clauses))))) - `(if ,test - (progn ,@forms) - (cond ,@(rest clauses))))))))) + (cond ,@more)))) + (if (eq t test) + `(progn ,@forms) + `(if ,test + (progn ,@forms) + ,(when more `(cond ,@more)))))))))) -;;; other things defined in terms of COND (defmacro-mundanely when (test &body forms) #!+sb-doc "If the first argument is true, the rest of the forms are - evaluated as a PROGN." - `(cond (,test nil ,@forms))) +evaluated as a PROGN." + `(if ,test (progn ,@forms) nil)) + (defmacro-mundanely unless (test &body forms) #!+sb-doc "If the first argument is not true, the rest of the forms are - evaluated as a PROGN." - `(cond ((not ,test) nil ,@forms))) +evaluated as a PROGN." + `(if ,test nil (progn ,@forms))) + (defmacro-mundanely and (&rest forms) (cond ((endp forms) t) ((endp (rest forms)) (first forms)) @@ -102,6 +106,7 @@ `(if ,(first forms) (and ,@(rest forms)) nil)))) + (defmacro-mundanely or (&rest forms) (cond ((endp forms) nil) ((endp (rest forms)) (first forms)) @@ -207,16 +212,19 @@ #-sb-xc-host (defun %defun (name def doc inline-lambda source-location) - (declare (ignore source-location)) (declare (type function def)) (declare (type (or null simple-string) doc)) (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN (sb!c:%compiler-defun name inline-lambda nil) (when (fboundp name) (/show0 "redefining NAME in %DEFUN") - (style-warn "redefining ~S in DEFUN" name)) + (style-warn 'sb!kernel::redefinition-with-defun :name name + :old (fdefinition name) :new def + :new-location source-location)) (setf (sb!xc:fdefinition name) def) + (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 @@ -224,7 +232,11 @@ #+nil (setf (%fun-name def) name) (when doc - (setf (fdocumentation name 'function) doc)) + (setf (fdocumentation name 'function) doc) + #!+sb-eval + (when (typep def 'sb!eval:interpreted-function) + (setf (sb!eval:interpreted-function-documentation def) + doc))) name) ;;;; DEFVAR and DEFPARAMETER @@ -320,27 +332,20 @@ ;;; destructuring mechanisms. (defmacro-mundanely dotimes ((var count &optional (result nil)) &body body) (cond ((numberp count) - `(do ((,var 0 (1+ ,var))) - ((>= ,var ,count) ,result) - (declare (type unsigned-byte ,var)) - ,@body)) - (t (let ((v1 (gensym))) - `(do ((,var 0 (1+ ,var)) (,v1 ,count)) - ((>= ,var ,v1) ,result) - (declare (type unsigned-byte ,var)) - ,@body))))) - -(defun filter-dolist-declarations (decls) - (mapcar (lambda (decl) - `(declare ,@(remove-if - (lambda (clause) - (and (consp clause) - (or (eq (car clause) 'type) - (eq (car clause) 'ignore)))) - (cdr decl)))) - decls)) - -(defmacro-mundanely dolist ((var list &optional (result nil)) &body body) + `(do ((,var 0 (1+ ,var))) + ((>= ,var ,count) ,result) + (declare (type unsigned-byte ,var)) + ,@body)) + (t + (let ((c (gensym "COUNT"))) + `(do ((,var 0 (1+ ,var)) + (,c ,count)) + ((>= ,var ,c) ,result) + (declare (type unsigned-byte ,var) + (type integer ,c)) + ,@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 @@ -350,28 +355,47 @@ ;; 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 @@ -559,39 +583,58 @@ (format stream ,format-string ,@format-arguments)) (values nil t)))) -(defmacro-mundanely handler-bind (bindings &body forms) - #!+sb-doc - "(HANDLER-BIND ( {(type handler)}* ) body) - Executes body in a dynamic context where the given handler bindings are - in effect. Each handler must take the condition being signalled as an - argument. The bindings are searched first to last in the event of a - signalled condition." +(defmacro-mundanely %handler-bind (bindings form) (let ((member-if (member-if (lambda (x) (not (proper-list-of-length-p x 2))) bindings))) (when member-if (error "ill-formed handler binding: ~S" (first member-if)))) - `(let ((*handler-clusters* - (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) - bindings)) - *handler-clusters*))) - (multiple-value-prog1 - (progn - ,@forms) - ;; Wait for any float exceptions. - #!+x86 (float-wait)))) + (let* ((local-funs nil) + (mapped-bindings (mapcar (lambda (binding) + (destructuring-bind (type handler) binding + (let ((lambda-form handler)) + (if (and (consp handler) + (or (eq 'lambda (car handler)) + (and (eq 'function (car handler)) + (consp (cdr handler)) + (let ((x (second handler))) + (and (consp x) + (eq 'lambda (car x)) + (setf lambda-form x)))))) + (let ((name (gensym "LAMBDA"))) + (push `(,name ,@(cdr lambda-form)) local-funs) + (list type `(function ,name))) + binding)))) + bindings))) + `(dx-flet (,@(reverse local-funs)) + (let ((*handler-clusters* + (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) + mapped-bindings)) + *handler-clusters*))) + (declare (truly-dynamic-extent *handler-clusters*)) + (progn ,form))))) + +(defmacro-mundanely handler-bind (bindings &body forms) + #!+sb-doc + "(HANDLER-BIND ( {(type handler)}* ) body) + +Executes body in a dynamic context where the given handler bindings are in +effect. Each handler must take the condition being signalled as an argument. +The bindings are searched first to last in the event of a signalled +condition." + `(%handler-bind ,bindings + #!-x86 (progn ,@forms) + ;; Need to catch FP errors here! + #!+x86 (multiple-value-prog1 (progn ,@forms) (float-wait)))) (defmacro-mundanely handler-case (form &rest cases) - "(HANDLER-CASE form - { (type ([var]) body) }* ) - Execute FORM in a context with handlers established for the condition - types. A peculiar property allows type to be :NO-ERROR. If such a clause - occurs, and form returns normally, all its values are passed to this clause - as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one - var specification." - ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND - ;; and names for the subexpressions would make it easier to - ;; understand the code below. + "(HANDLER-CASE form { (type ([var]) body) }* ) + +Execute FORM in a context with handlers established for the condition types. A +peculiar property allows type to be :NO-ERROR. If such a clause occurs, and +form returns normally, all its values are passed to this clause as if by +MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one var +specification." (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause (let ((normal-return (make-symbol "normal-return")) @@ -602,41 +645,47 @@ (return-from ,error-return (handler-case (return-from ,normal-return ,form) ,@(remove no-error-clause cases))))))) - (let ((tag (gensym)) - (var (gensym)) - (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) - cases))) - `(block ,tag - (let ((,var nil)) - (declare (ignorable ,var)) - (tagbody - (handler-bind - ,(mapcar (lambda (annotated-case) - (list (cadr annotated-case) - `(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (go ,(car annotated-case))))) - annotated-cases) - (return-from ,tag - #!-x86 ,form - #!+x86 (multiple-value-prog1 ,form - ;; Need to catch FP errors here! - (float-wait)))) - ,@(mapcan - (lambda (annotated-case) - (list (car annotated-case) - (let ((body (cdddr annotated-case))) - `(return-from - ,tag - ,(cond ((caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body)) - (t - `(locally ,@body))))))) - annotated-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) + `(dx-flet ((,form-fun () + #!-x86 ,form + ;; Need to catch FP errors here! + #!+x86 (multiple-value-prog1 ,form (float-wait))) + ,@(reverse local-funs)) + (declare (optimize (sb!c::check-tag-existence 0))) + (block ,block + (dx-let ((,var nil)) + (declare (ignorable ,var)) + (tagbody + (%handler-bind + ,(mapcar (lambda (annotated-case) + (destructuring-bind (tag type ll fun-name) annotated-case + (declare (ignore fun-name)) + (list type + `(lambda (temp) + ,(if ll + `(setf ,var temp) + '(declare (ignore temp))) + (go ,tag))))) + annotated-cases) + (return-from ,block (,form-fun))) + ,@(mapcan + (lambda (annotated-case) + (destructuring-bind (tag type ll fun-name) annotated-case + (declare (ignore type)) + (list tag + `(return-from ,block + ,(if ll + `(,fun-name ,var) + `(,fun-name)))))) + annotated-cases)))))))))) ;;;; miscellaneous