[Openmcl-cvs-notifications] r12995 - in /trunk/source/lib: level-2.lisp macros.lisp

[gz at clozure.com]

Author: gz
Date: Sat Oct 10 18:11:09 2009
New Revision: 12995

Log:
svn ci -m "Merge r12980, replacing r12646 (which defeated type optimization=
s in addition to being buggy)"

Modified:
    trunk/source/lib/level-2.lisp
    trunk/source/lib/macros.lisp

Modified: trunk/source/lib/level-2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/level-2.lisp (original)
+++ trunk/source/lib/level-2.lisp Sat Oct 10 18:11:09 2009
@@ -48,7 +48,6 @@
 ; This is so we can be pedantic about binding &WHOLE/&ENVIRONMENT args
 ; that have been scarfed out of a macro-like lambda list.
 ; The returned value is supposed to be suitable for splicing ...
-#+not-used
 (defun hoist-special-decls (sym decls)
   (when sym
     (dolist (decl decls)

Modified: trunk/source/lib/macros.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/macros.lisp (original)
+++ trunk/source/lib/macros.lisp Sat Oct 10 18:11:09 2009
@@ -177,68 +177,28 @@
 (defmacro %vstack-block (spec &body forms)
   `(%stack-block (,spec) , at forms))
 =

-
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun extract-type-decl-for-dolist-var (var decls env)
-  (if (null decls)
-    (values nil nil nil)
-    (let* ((declared-type-p nil))
-      (collect ((new-decls)
-                (declared-types))
-        (dolist (declform decls)
-          ;; (assert (eq (car declform) 'declare))
-          (dolist (decl (cdr declform))
-            (if (atom decl)
-              (new-decls decl)
-              (let* ((spec (car decl)))
-                (if (specifier-type-if-known spec env)
-                  (setq spec 'type
-                        decl `(type , at decl)))
-                (if (eq spec 'type)
-                  (destructuring-bind (typespec &rest vars) (cdr decl)
-                    (cond ((member var vars :test #'eq)
-                           (setq declared-type-p t)
-                           (declared-types typespec)
-                           (new-decls `(type ,typespec ,@(remove var vars)=
)))
-                          (t (new-decls decl))))
-                  (new-decls decl))))))
-        (if (not declared-type-p)
-          (values nil nil (new-decls))
-          (values t
-                  (let* ((declared-type (declared-types)))
-                    (if (cdr declared-type)
-                      `(and , at declared-type)
-                      (car declared-type)))
-                  (new-decls)))))))
-)
-
-
 (defmacro dolist ((varsym list &optional ret) &body body &environment env)
   (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym))
   (let* ((toplab (gensym))
          (tstlab (gensym))
          (lstsym (gensym)))
     (multiple-value-bind (forms decls) (parse-body body env nil)
-      (multiple-value-bind (var-type-p vartype other-decls)
-          (extract-type-decl-for-dolist-var varsym decls env)
-        (if var-type-p
-          (setq forms `((locally (declare (type ,vartype ,varsym)) (tagbod=
y , at forms)))))
-        (if other-decls
-          (setq other-decls `((declare , at other-decls))))
-        `(block nil
-          (let* ((,lstsym ,list) ,varsym)
-            ,@(if var-type-p `((declare (type (or null ,vartype) ,varsym))=
))
-            , at other-decls
-            (tagbody
-               (go ,tstlab)
-               ,toplab
-               (setq ,lstsym (cdr (the list ,lstsym)))
-               , at forms
-               ,tstlab
-               (setq ,varsym (car ,lstsym))
-               (if ,lstsym (go ,toplab)))
-            ,@(if ret `((progn  ,ret)))))))))
+      `(block nil
+         (let* ((,lstsym ,list))
+           (tagbody
+              (go ,tstlab)
+              ,toplab
+              (let ((,varsym (car ,lstsym)))
+                , at decls
+                (tagbody
+                   , at forms)
+                (setq ,lstsym (cdr (the list ,lstsym))))
+              ,tstlab
+              (if ,lstsym (go ,toplab))))
+         ,@(if ret `((let ((,varsym nil))
+                       ,@(hoist-special-decls varsym decls)
+                       (declare (ignore-if-unused ,varsym))
+                       ,ret)))))))
 =

 =

 (defmacro dovector ((varsym vector &optional ret) &body body &environment =
env)