Changeset 12995


Ignore:
Timestamp:
Oct 10, 2009, 10:11:09 PM (10 years ago)
Author:
gz
Message:

svn ci -m "Merge r12980, replacing r12646 (which defeated type optimizations in addition to being buggy)"

Location:
trunk/source/lib
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/level-2.lisp

    r12535 r12995  
    4949; that have been scarfed out of a macro-like lambda list.
    5050; The returned value is supposed to be suitable for splicing ...
    51 #+not-used
    5251(defun hoist-special-decls (sym decls)
    5352  (when sym
  • trunk/source/lib/macros.lisp

    r12940 r12995  
    178178  `(%stack-block (,spec) ,@forms))
    179179
    180 
    181 
    182 (eval-when (:compile-toplevel :load-toplevel :execute)
    183 (defun extract-type-decl-for-dolist-var (var decls env)
    184   (if (null decls)
    185     (values nil nil nil)
    186     (let* ((declared-type-p nil))
    187       (collect ((new-decls)
    188                 (declared-types))
    189         (dolist (declform decls)
    190           ;; (assert (eq (car declform) 'declare))
    191           (dolist (decl (cdr declform))
    192             (if (atom decl)
    193               (new-decls decl)
    194               (let* ((spec (car decl)))
    195                 (if (specifier-type-if-known spec env)
    196                   (setq spec 'type
    197                         decl `(type ,@decl)))
    198                 (if (eq spec 'type)
    199                   (destructuring-bind (typespec &rest vars) (cdr decl)
    200                     (cond ((member var vars :test #'eq)
    201                            (setq declared-type-p t)
    202                            (declared-types typespec)
    203                            (new-decls `(type ,typespec ,@(remove var vars))))
    204                           (t (new-decls decl))))
    205                   (new-decls decl))))))
    206         (if (not declared-type-p)
    207           (values nil nil (new-decls))
    208           (values t
    209                   (let* ((declared-type (declared-types)))
    210                     (if (cdr declared-type)
    211                       `(and ,@declared-type)
    212                       (car declared-type)))
    213                   (new-decls)))))))
    214 )
    215 
    216 
    217180(defmacro dolist ((varsym list &optional ret) &body body &environment env)
    218181  (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym))
     
    221184         (lstsym (gensym)))
    222185    (multiple-value-bind (forms decls) (parse-body body env nil)
    223       (multiple-value-bind (var-type-p vartype other-decls)
    224           (extract-type-decl-for-dolist-var varsym decls env)
    225         (if var-type-p
    226           (setq forms `((locally (declare (type ,vartype ,varsym)) (tagbody ,@forms)))))
    227         (if other-decls
    228           (setq other-decls `((declare ,@other-decls))))
    229         `(block nil
    230           (let* ((,lstsym ,list) ,varsym)
    231             ,@(if var-type-p `((declare (type (or null ,vartype) ,varsym))))
    232             ,@other-decls
    233             (tagbody
    234                (go ,tstlab)
    235                ,toplab
    236                (setq ,lstsym (cdr (the list ,lstsym)))
    237                ,@forms
    238                ,tstlab
    239                (setq ,varsym (car ,lstsym))
    240                (if ,lstsym (go ,toplab)))
    241             ,@(if ret `((progn  ,ret)))))))))
     186      `(block nil
     187         (let* ((,lstsym ,list))
     188           (tagbody
     189              (go ,tstlab)
     190              ,toplab
     191              (let ((,varsym (car ,lstsym)))
     192                ,@decls
     193                (tagbody
     194                   ,@forms)
     195                (setq ,lstsym (cdr (the list ,lstsym))))
     196              ,tstlab
     197              (if ,lstsym (go ,toplab))))
     198         ,@(if ret `((let ((,varsym nil))
     199                       ,@(hoist-special-decls varsym decls)
     200                       (declare (ignore-if-unused ,varsym))
     201                       ,ret)))))))
    242202
    243203
Note: See TracChangeset for help on using the changeset viewer.