iterate in Genera 7.1

[Gregor.pa@Xerox.COM]

    Date: Mon, 15 Aug 88 14:39:10 cdt
    From: Kurt D. Krebsbach <"krebsbach@hi-csc.honeywell.com"@hi-csc.honeywell.com>

    I've been having a hard time trying to compile the file iterate.lisp on a
    Symbolics under Genera 7.1.  This has happened exactly the same way when
    trying to compile both the 7/7/88 release, and the 8/2/ release.

There is a new version of the file iterate.lisp on arisia.xerox.com
which corrects this problem.  Either FTP the new version, or make the
following patch to your version:

;from iterate.lisp
(defun optimize-iterate-form (type clauses body iterate-env)
   (let*
    ((temp-vars *iterate-temp-vars-list*)
     (block-name (gensym))
     (finish-form `(return-from ,block-name))
     (bound-vars (mapcan #'(lambda (clause)
                                  (let ((names (first clause)))
                                       (if (listp names)
                                           (copy-list names)
                                           (list names))))
                        clauses))
     iterate-decls generator-decls update-forms bindings final-bindings 
     leftover-body)
    (do ((tail bound-vars (cdr tail)))
        ((null tail))                          ; check for duplicates
      (when (member (car tail)
                   (cdr tail))
          (warn "variable appears more than once in iterate: ~s" (car tail))))
    (flet
     ((get-iterate-temp nil                    ; make temporary var.  note
                                               ; that it is ok to re-use these
                                               ; symbols in each iterate,
                                               ; because they are not used
                                               ; within body.
             (or (pop temp-vars)
                 (gensym))))
     (dolist (clause clauses)
         (cond
            ((or (not (consp clause))
                 (not (consp (cdr clause))))
             (warn 
                 "bad syntax in iterate: clause not of form (var iterator): ~s"
                   clause))
            (t
             (unless (null (cddr clause))
                    (warn 
       "probable parenthesis error in iterate clause--more than 2 elements: ~s"
                          clause))
             (multiple-value-bind
              (let-body binding-type let-bindings localdecls otherdecls 
                     extra-body)
              (expand-into-let (second clause)
                     type iterate-env)

              ;; we have expanded the generator clause and parsed it into its
              ;; let pieces.
              (prog* ((vars (first clause))
                      gen-args renamed-vars)
		  (block punt1
                     (setq vars (if (listp vars)
                                    (copy-list vars)
                                    (list vars)))
                                               ; vars is now a (fresh) list of
                                               ; all iteration vars bound in
                                               ; this clause
                     (when (setq let-body (function-lambda-p let-body 1))

                         ;; we have something of the form #'(lambda
                         ;; (finisharg) ...), possibly with some let bindings
                         ;; around it.  
                         (setq let-body (cdr let-body))
                         (setq gen-args (pop let-body))
                         (when let-bindings

                          ;; the first transformation we want to perform is
                          ;; "let-eversion": turn (let* ((generator (let
                          ;; (..bindings..) #'(lambda ...)))) ..body..) into
                          ;; (let* (..bindings.. (generator #'(lambda ...)))
                          ;; ..body..).  this transformation is valid if
                          ;; nothing in body refers to any of the bindings,
                          ;; something we can assure by alpha-converting the
                          ;; inner let (substituting new names for each var). 
                          ;; of course, none of those vars can be special, but
                          ;; we already checked for that above.
                             (multiple-value-setq (let-bindings renamed-vars)
                                    (rename-let-bindings let-bindings 
                                           binding-type iterate-env 
                                           leftover-body #'get-iterate-temp))
                             (setq leftover-body nil)
                                               ; if there was any leftover
                                               ; from previous, it is now
                                               ; consumed
                             
                             )
                         (let
                          ((finish-arg (first gen-args)))

                          ;; the second transformation is substituting the
                          ;; body of the generator (lambda (finish-arg) .
                          ;; gen-body) for its appearance in the update form
                          ;; (funcall generator #'(lambda () finish-form)),
                          ;; then simplifying that form.  the requirement for
                          ;; this part is that the generator body not refer to
                          ;; any variables that are bound between the
                          ;; generator binding and the appearance in the loop
                          ;; body.  the only variables bound in that interval
                          ;; are generator temporaries, which have unique
                          ;; names so are no problem, and the iteration
                          ;; variables themselves: all of them in the case of
                          ;; iterate, only the remaining ones in the case of
                          ;; iterate*.  we'll discover the story as we walk
                          ;; the body.
                          (multiple-value-bind
                           (finishdecl other rest)
                           (parse-declarations let-body gen-args)
                           (declare (ignore finishdecl))
                                               ; pull out declares, if any,
                                               ; separating out the one(s)
                                               ; referring to the finish arg,
                                               ; which we will throw away
                           (when other         ; combine remaining decls with
                                               ; decls extracted from the let,
                                               ; if any
                               (setq otherdecls (nconc otherdecls other)))
                           (setq
                            let-body
                            (cond
                               (otherdecls     ; there are interesting
                                               ; declarations, so have to keep
                                               ; it wrapped.
                                `(let nil (declare ,@otherdecls)
                                      ,@rest))
                               ((null (cdr rest))
                                               ; only one form left
                                (first rest)))))
                          (setq
                           let-body
                           (walk-form
                            let-body iterate-env
                            #'(lambda (form context env)
                                     (declare (ignore context))

                                ;; need to substitute renamed-vars, as well as
                                ;; turn (funcall finish-arg) into the finish
                                ;; form
                                     (cond
                                        ((symbolp form)
                                         (let (renaming)
                                              (cond
                                                 ((and (eq form finish-arg)
                                                       (variable-same-p form 
                                                              env iterate-env))
                                               ; an occurrence of the finish
                                               ; arg outside of funcall
                                               ; context--i can't handle this
                                                  (maybe-warn :definition "couldn't optimize ~s because generator ~s does something with its finish arg besides funcall it."
                                                         type (second clause))
                                                 ;(go punt)
						  (return-from punt1 nil)
						  )
                                                 ((and (setq renaming
                                                             (assoc form 
                                                                   renamed-vars
                                                                    ))
                                                       (variable-same-p form 
                                                              env iterate-env))
                                               ; reference to one of the vars
                                               ; we're renaming
                                                  (cdr renaming))
                                                 ((and (member form bound-vars)
                                                       (variable-same-p form 
                                                              env iterate-env))
                                               ; form is a var that is bound
                                               ; in this same iterate, or
                                               ; bound later in this iterate*.
                                               ; this is a conflict.
                                                  (maybe-warn
                                                   :user "couldn't optimize ~s because generator ~s is closed over ~s, in conflict with another iteration variable.~@[  you may have meant to use iterate*~]"
                                                   type (second clause)
                                                   form
                                                   (eq type 'iterate))
                                                 ;(go punt)
						  (return-from punt1 nil)
						  )
                                                 (t form))))
                                        ((and (consp form)
                                              (eq (first form)
                                                  'funcall)
                                              (eq (second form)
                                                  finish-arg)
                                              (variable-same-p (second form)
                                                     env iterate-env))
                                               ; (funcall finish-arg) =>
                                               ; finish-form
                                         (unless (null (cddr form))
                                             (maybe-warn :definition 
        "generator for ~s applied its finish arg to > 0 arguments ~s--ignored."
                                                    (second clause)
                                                    (cddr form)))
                                         finish-form)
                                        (t form)))))

                          ;; gen-body is now a form which, when evaluated,
                          ;; returns updated values for the iteration
                          ;; variable(s)
                          (push (mv-setq (copy-list vars)
                                       let-body)
                                update-forms)

                          ;; note possible further optimization: if the above
                          ;; expanded into (setq var (prog1 oldvalue
                          ;; prepare-for-next-iteration)), as so many do, then
                          ;; we could in most cases split the prog1 into two
                          ;; pieces: do the (setq var oldvalue) here, and do
                          ;; the prepare-for-next-iteration at the bottom of
                          ;; the loop.  this does a slight optimization of the
                          ;; prog1 and also rearranges the code in a way that
                          ;; a reasonably clever compiler might detect how to
                          ;; get rid of redundant variables altogether (such
                          ;; as happens with interval and list-tails); that
                          ;; would make the whole thing closer to what you
                          ;; might have coded by hand.  however, to do this
                          ;; optimization, we need to assure that (a) the
                          ;; prepare-for-next-iteration refers freely to no
                          ;; vars other than the internal vars we have
                          ;; extracted from the let, and (b) that the code has
                          ;; no side effects.  these are both true for all the
                          ;; iterators defined by this module, but how shall
                          ;; we represent side-effect info and/or tap into the
                          ;; compiler's knowledge of same?
                          (when localdecls     ; there were declarations for
                                               ; the generator locals--have to
                                               ; keep them for later, and
                                               ; rename the vars mentioned
                              (setq
                               generator-decls
                               (nconc
                                generator-decls
                                (mapcar
                                 #'(lambda
                                    (decl)
                                    (let
                                     ((head (car decl)))
                                     (cons head
                                           (if (eq head 'type)
                                               (cons (second decl)
                                                     (sublis renamed-vars
                                                            (cddr decl)))
                                               (sublis renamed-vars
                                                      (cdr decl))))))
                                 localdecls))))
                          (go finish-clause)))
                     (maybe-warn :definition "could not optimize ~s clause ~s because generator not of form (let[*] ... (function (lambda (finish) ...)))"
                            type (second clause))
		     );end of block punt1
                 punt
                     (let
                      ((gvar (get-iterate-temp))
                       (generator (second clause)))

                      ;; for some reason, we can't expand this guy, so go with
                      ;; the formal semantics: bind a var to the generator,
                      ;; then call it in the update section
                      (setq
                       let-bindings
                       (list
                        (list gvar
                              (cond
                                 (leftover-body; have to use this up
                                  `(progn ,@(prog1 leftover-body
                                                   (setq leftover-body nil))
                                          generator))
                                 (t generator)))))
                      (push (mv-setq (copy-list vars)
                                   `(funcall ,gvar #'(lambda nil ,finish-form))
                                   )
                            update-forms))
                 finish-clause
                     (case type
                         (iterate              ; for iterate, don't bind any
                                               ; iv's until all exprs are
                                               ; evaluated, so defer this
                            (setq final-bindings (nconc final-bindings vars))
                            (setq vars nil)
                            (when extra-body   ; have to save this for next
                                               ; clause, too
                                (setq leftover-body (nconc leftover-body 
                                                           extra-body))
                                (setq extra-body nil)))
                         (iterate*             ; pop off the vars we have now
                                               ; bound from the list of vars
                                               ; to watch out for--we'll bind
                                               ; them right now
                            (dolist (v vars)
			      #-Genera
			      (declare (ignore v))
			      (pop bound-vars))))
                     (setq
                      bindings
                      (nconc bindings let-bindings
                             (cond
                                (extra-body    ; there was some computation to
                                               ; do after the bindings--here's
                                               ; our chance
                                 (cons (list (first vars)
                                             `(progn ,@extra-body nil))
                                       (rest vars)))
                                (t vars))))))))))
    (do ((tail body (cdr tail)))
        ((not (and (consp tail)
                   (consp (car tail))
                   (eq (caar tail)
                       'declare)))             ; tail now points at first
                                               ; non-declaration.  if there
                                               ; were declarations, pop them
                                               ; off so they appear in the
                                               ; right place
         (unless (eq tail body)
             (setq iterate-decls (ldiff body tail))
             (setq body tail))))
    `(block ,block-name
         (let* ,(append bindings final-bindings)
               ,@(and generator-decls `((declare ,@generator-decls)))
               ,@iterate-decls
               ,@leftover-body
               (loop ,@(nreverse update-forms)
                     ,@body)))))
-------