X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefboot.lisp;h=0df13b61e51aa501507a0967416ba9fed55ef59d;hb=aa1a5c6ea31c248587d78f62943ad749ea8fbe2f;hp=f36232b513495171b366288af3a3db2392d67bd3;hpb=bef03694b858728bfe9481385631daeda607b5c6;p=sbcl.git

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index f36232b..0df13b6 100644
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -212,14 +212,15 @@ evaluated as a PROGN."
 
 #-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)
@@ -344,7 +345,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
@@ -354,28 +355,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
 
@@ -572,29 +592,27 @@ 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))))))
+                                                          (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))
-         (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)))))
+         (declare (truly-dynamic-extent *handler-clusters*))
+         (progn ,form)))))
 
 (defmacro-mundanely handler-bind (bindings &body forms)
   #!+sb-doc