Changeset 12646


Ignore:
Timestamp:
Aug 23, 2009, 12:09:22 PM (10 years ago)
Author:
gb
Message:

Revert DOLIST to the traditional version; hack declarations so that
if there's a TYPE declaration on VAR, it's widened to (OR NULL type)
when the iteration variable can be NIL and narrowed when it's known
not to be.

This seems to ... um, further highlight ... our problems with
typechecking at SAFETY 3. (Most of which are problems with SAFETY 3
being so ridiculous ...)

I think that more things that the spec says about DOLIST are likely
to be true in this expansion than in the one that we'd been using,
but wouldn't claim to really like this.

File:
1 edited

Legend:

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

    r12591 r12646  
    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
    180217(defmacro dolist ((varsym list &optional ret) &body body &environment env)
    181218  (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym))
     
    184221         (lstsym (gensym)))
    185222    (multiple-value-bind (forms decls) (parse-body body env nil)
    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                        (declare (ignorable ,varsym))
    200                        ;;,@decls
    201                        ,ret)))))))
     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)))))))))
    202242
    203243
Note: See TracChangeset for help on using the changeset viewer.