Changeset 13080


Ignore:
Timestamp:
Oct 22, 2009, 2:37:21 AM (10 years ago)
Author:
gb
Message:

Yet another DOLIST implementation: separate "bound" decls for VAR
from other decls.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/macros.lisp

    r13067 r13080  
    179179  `(%stack-block (,spec) ,@forms))
    180180
     181(eval-when (:compile-toplevel :load-toplevel :execute)
     182(defun extract-bound-decls-for-dolist-var (var decls env)
     183  (if (null decls)
     184    (values nil nil)
     185      (collect ((var-decls)
     186                (other-decls))
     187        (dolist (declform decls
     188                 (let* ((vdecls (var-decls))
     189                        (others (other-decls)))
     190                   (values (if vdecls `((declare ,@vdecls)))
     191                           (if others `((declare ,@others))))))
     192          ;; (assert (eq (car declform) 'declare))
     193          (dolist (decl (cdr declform))
     194            (if (atom decl)
     195              (other-decls decl)
     196              (let* ((spec (car decl)))
     197                (if (specifier-type-if-known spec env)
     198                  (setq spec 'type
     199                        decl `(type ,@decl)))
     200                (case spec
     201                  (type
     202                   (destructuring-bind (typespec &rest vars) (cdr decl)
     203                     (cond ((member var vars :test #'eq)
     204                            (setq vars (delete var vars))
     205                            (var-decls `(type ,typespec ,var))
     206                            (when vars
     207                              (other-decls `(type ,typespec ,@vars))))
     208                           (t (other-decls decl)))))
     209                   ((special ingore ignorable ccl::ignore-if-unused)
     210                    (let* ((vars (cdr decl)))
     211                      (cond ((member var vars :test #'eq)
     212                             (setq vars (delete var vars))
     213                             (var-decls `(,spec ,var))
     214                             (when vars
     215                               (other-decls `(,spec ,@vars))))
     216                            (t (other-decls decl)))))
     217                   (t (other-decls decl))))))))))
     218)
     219
     220
     221
    181222(defmacro dolist ((varsym list &optional ret) &body body &environment env)
    182223  (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym))
    183   (let* ((toplab (gensym))
    184          (tstlab (gensym))
    185          (lstsym (gensym)))
    186224    (multiple-value-bind (forms decls) (parse-body body env nil)
    187       `(block nil
    188          (let* ((,lstsym ,list))
    189            (tagbody
    190               (go ,tstlab)
    191               ,toplab
    192               (let ((,varsym (car ,lstsym)))
    193                 ,@decls
    194                 (tagbody
    195                    ,@forms)
    196                 (setq ,lstsym (cdr (the list ,lstsym))))
    197               ,tstlab
    198               (if ,lstsym (go ,toplab))))
    199          ,@(if ret `((let ((,varsym nil))
    200                        (declare (ignore-if-unused ,varsym)
    201                                 ,@(loop for decl in decls
    202                                         append (remove 'special (cdr decl) :test #'neq :key #'car)))
    203                        ,ret)))))))
     225      (multiple-value-bind (var-decls other-decls)
     226          (extract-bound-decls-for-dolist-var varsym decls env)
     227        (let* ((lstsym (gensym)))
     228        `(do* ((,lstsym ,list (cdr (the list ,lstsym))))
     229              ((null ,lstsym)
     230               ,@(if ret `((let* ((,varsym ()))
     231                             (declare (ignorable ,varsym))
     232                             ,ret))))
     233          ,@other-decls
     234          (let* ((,varsym (car ,lstsym)))
     235            ,@var-decls
     236            (tagbody ,@forms)))))))
    204237
    205238(defmacro dovector ((varsym vector &optional ret) &body body &environment env)
Note: See TracChangeset for help on using the changeset viewer.