From: Nikodemus S. <de...@us...> - 2008-08-03 21:39:13
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv10713/src/code Modified Files: defboot.lisp early-extensions.lisp Log Message: 1.0.19.17: DOLIST variable type on constant lists * When DOLIST list is a (LIST ...) form where every argument is a constant, constant-fold it during macro-expansion. (User has no direct access to the list itself, so this is safe.) * When DOLIST list ia a constant, add an extra binding, and annotate its type as (MEMBER ...). This means that the compiler knows that in (dolist (x (list 1 2 3)) ...) X is (INTEGER 1 3). * Also add a STYLE-WARNING for constant dotted lists in DOLIST. Index: defboot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/defboot.lisp,v retrieving revision 1.63 retrieving revision 1.64 diff -u -d -r1.63 -r1.64 --- defboot.lisp 30 Jul 2008 17:58:40 -0000 1.63 +++ defboot.lisp 3 Aug 2008 21:39:10 -0000 1.64 @@ -345,7 +345,7 @@ (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 +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 Index: early-extensions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v retrieving revision 1.96 retrieving revision 1.97 diff -u -d -r1.96 -r1.97 --- early-extensions.lisp 30 Jul 2008 17:58:40 -0000 1.96 +++ early-extensions.lisp 3 Aug 2008 21:39:10 -0000 1.97 @@ -1214,6 +1214,16 @@ (*print-length* (or (true *print-length*) 12))) (funcall function)))) +;;; Returns a list of members of LIST. Useful for dealing with circular lists. +;;; For a dotted list returns a secondary value of T -- in which case the +;;; primary return value does not include the dotted tail. +(defun list-members (list) + (when list + (do ((tail (cdr list) (cdr tail)) + (members (list (car list)) (cons (car tail) members))) + ((or (not (consp tail)) (eq tail list)) + (values members (not (listp tail))))))) + ;;; Default evaluator mode (interpeter / compiler) (declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*)) |