;;;-*- syntax:COMMON-LISP; Package: (ITERATE :use "COMMON-LISP" :colon-mode :external) -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; ITERATE, An Iteration Macro

;;;

;;; Copyright 1989 by Jonathan Amsterdam

;;; Adapted to ANSI Common Lisp in 2003 by Andreas Fuchs

;;;

;;; Permission to use, copy, modify, and distribute this software and its

;;; documentation for any purpose and without fee is hereby granted,

;;; provided that this copyright and permission notice appear in all

;;; copies and supporting documentation, and that the name of M.I.T. not

;;; be used in advertising or publicity pertaining to distribution of the

;;; software without specific, written prior permission. M.I.T. makes no

;;; representations about the suitability of this software for any

;;; purpose. It is provided "as is" without express or implied warranty.

;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING

;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL

;;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR

;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,

;;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,

;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS

;;; SOFTWARE.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; FIXES.

;;; (v. 1.2-ansi)

;;; 2004-11-30 - Joerg Hoehle: a dozen small fixes to various functions

;;; 2003-12-16 - Tested a bit more, implemented FOR-HASHTABLE and

;;; FOR-PACKAGES (FOR-PACKAGE) iteration CLtS-style

;;; using (with-{package,hashtable}-iterator)

;;; 2003-12-16 - ported iterate-1.2 to ANSI Common Lisp (in the form

;;; of SBCL). Extremely untested. Works for simple

;;; examples, though.

;;; (v. 1.2)

;;; 6/14/91 - fixed generation of previous code

;;; 5/6/91 - improved code generated for COLLECT and ADJOINING

;;; 4/10/91 - added *binding-context?* to correctly determine when inside

;;; a binding context

;;; 12/20/90 - fixed ,. bug in IN-HASHTABLE

;;; 3/3/91 - no longer generates loop-end and loop-step tags if they're not

;;; used, to avoid compiler warnings from some compilers (Allegro)

;;; 3/4/91 - treat cond as a special form for allegro

;;; (v. 1.1.1)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; OUTSTANDING PROBLEMS & QUESTIONS:

;;; - What happens if there are two contradictory declarations

;;; about a variable's type? We just take the second one. CLM

;;; doesn't say, but presumably this is an error. Let's say it is.

;;;

;;; - Is there a more general way to do synonyms that still allows

;;; some specificity to particular clauses? Right now, all we allow

;;; is for the first words of clauses to have synonyms.

;;;

;;; - We should look at function type declarations, at least at the

;;; result type, and record them.

;;;

;;; - Consider adding an if-never keyword to find...max/min

;;;

;;; - Consider allowing accumulation variables to be generalized

;;; variables, acceptable to setf.

;;;

;;; - Consider parsing type declarations of the form (vector * integer),

;;; to generate types for internal variables.

;;;

;;; - Vector destructuring?

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; TO DO:

;;; - do I walk &optional and &key code in lambda-lists?

;;; - try binding *macroexpand-hook* in walk

;;; - track down PREVIOUS bug in Symbolics and sparc lucid

;;; - reducing and accum: RESULT-TYPE

;;; - rethink types

;;; - how to type result var?

;;; - (for var concatenate (from 1 to 10) (in '(a b c)) (next (gensym)))

;;; - (if (< var 10)

;;; (next [from-to])

;;; (if lst

;;; (next [in])

;;; (gensym)))

;;; - for var choose, for var repeatedly

;;; For CL version 2:

;;; - variable info from environments

;;; - macro info " " (so we can support macrolet)

;;; - use errors for EOF

;;; - change WALK and FREE-VARIABLES to take symbol macros into account

;;; - array indices are fixnums

;;; - type REAL for extremum clauses

;;; Maybe:

;;; - decls can appear not at top level, as long as they appear before use.

;;; - extremum and find-extremum should do reductions when possible

;;; - optimize collections, hashtables, packages for lispms

;;; - fix :using-type-of to check for supplied ???

;;; - for-in should allow numerical keywords (from, to, etc.)...?

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; TO TEST:

;;; - leaving driver code where it is

;;; - typing

;;; - macroexpand & walk after-each

;;; - check for duplicate keywords in defclause, defmacro-clause

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; TO DOCUMENT:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Some of the 7 extremely random interface commands

;;; got replaced by defpackage.

;;; Use uninterned symbols here so that:

;;; 1. there's no iterate symbol in package USER.

;;; 2. it may work in case-sensitive mode/packages.

(defpackage #:iterate

(:use #:cl)

(:nicknames #:ITER)

(:export #:iterate #:iter #:display-iterate-clauses

#:defsynonym #:dsetq #:declare-variables

#:defmacro-clause #:defmacro-driver #:defclause-sequence

#:initially #:after-each #:finally #:finally-protected

#:else #:if-first-time #:first-iteration-p #:first-time-p

#:finish #:leave #:next-iteration #:next #:terminate

#:repeat #:for #:as #:generate #:generating #:in

#:sum #:summing #:multiply #:multiplying

#:maximize #:minimize #:maximizing #:minimizing #:counting

#:always #:never #:thereis #:finding #:collect #:collecting

#:with #:while #:until #:adjoining #:nconcing #:appending

#:nunioning #:unioning #:reducing #:accumulate #:accumulating))

(in-package #:iterate)

;;; work around sbcl's obnoxious standard compliance

(defmacro defconst (name value &optional doc)

`(eval-when (:compile-toplevel :load-toplevel :execute)

(unless (boundp ',name)

,(if doc

`(defconstant ,name ,value ,doc)

`(defconstant ,name ,value)))))

(declaim (declaration declare-variables))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Constants and global variables.

(defconst version "1.4" "Current version of Iterate")

(defconst standard-type-symbols ; of CLtL2

'(array atom bignum bit bit-vector boolean character compiled-function

complex cons double-float fixnum float function hash-table integer

keyword list long-float nil null number package pathname random-state

ratio rational readtable real sequence short-float signed-byte simple-array

simple-bit-vector simple-string simple-vector single-float standard-char

stream string string-char symbol t unsigned-byte vector)

"Table 4-1 of the Common Lisp Manual")

;;; These next two can be used for maximizing and minimizing.

# nil ;; unused

(defconst smallest-number-alist

`((fixnum . ,most-negative-fixnum)

(float . ,most-negative-long-float)

(long-float . ,most-negative-long-float)

(short-float . ,most-negative-short-float)

(double-float . ,most-negative-double-float)

(single-float . ,most-negative-single-float)))

# nil ;; unused

(defconst largest-number-alist

`((fixnum . ,most-positive-fixnum)

(float . ,most-positive-long-float)

(long-float . ,most-positive-long-float)

(short-float . ,most-positive-short-float)

(double-float . ,most-positive-double-float)

(single-float . ,most-positive-single-float)))

;;; This is like (declare (declare-variables)).

(defvar *always-declare-variables* nil)

;;; *result-var* is bound to a gensym before the clauses of an iterate

;;; form are processed. In the generated code, the gensym is bound

;;; to nil before any other bindings are performed. Clauses are free

;;; to generate code that sets the value of *result-var*.

(defvar *result-var*)

;;; Iterate binds *type-alist* to an alist of variables and their

;;; types before processing clauses. It does this by looking at

;;; (declare (type ...)) forms in the clauses and recording the information

;;; there. (Just variable type information, not function.)

(defvar *type-alist*)

;;; *declare-variables* is bound to T iff the

;;; (declare (iterate:declare-variables))

;;; declaration was seen at top-level, or if

;;; *always-declare-variables* is non-nil. This indicates that variables

;;; that haven't been declared by the user should be declared to have

;;; the appropriate types. What "appropriate" means depends on the

;;; context.

(defvar *declare-variables*)

;;; *clause* is bound to each entire iterate clause before the clause

;;; is processed. Mostly for error output (see clause-error).

(defvar *clause*)

;;; *top-level?* is bound to T at top-level (i.e. before any forms that

;;; contain clauses inside them, like IF, LET, etc.) and to NIL

;;; inside such forms. It is useful to ensure that certain forms

;;; (particularly iteration drivers) occur only at top-level.

(defvar *top-level?*)

;;; *binding-context?* a misnomer, should be named *declaration-context*, is

;;; bound to T inside a form that allows declarations (flet, labels). We used

;;; to just see if *internal-variables* was non-nil, but that's wrong--you can

;;; be inside a binding context that binds no variables.

(defvar *binding-context?*)

;;; For the use of make-binding-internal, to pass back bindings.

;;; if-1st-time also uses it to create first-time variables.

(defvar *bindings*)

;;; This is a list of variable-lists containing the variables made by

;;; internal let's or other binding forms. It is used to check for

;;; the error of having iterate try to bind one of these variables at

;;; top-level. E.g.

;;; (iterate (for i from 1 to 10)

;;; (let ((a nil))

;;; (collect i into a)))

;;; is an error.

(defvar *internal-variables*)

;;; For functions (like make-binding) that don't want to or can't pass

;;; declarations normally. These are really decl-specs, not full

;;; declarations.

(defvar *declarations*)

;;; This is how we get multiple accumulations into the same variable

;;; to come out right. See make-accum-var-binding.

;;; It's an alist of (accum-var kind <possibly other info>).

;;; The currently used kinds are:

;;; :collect for collect, nconc, append, etc.

;;; :increment for count, sum and multiply

;;; :max for maximize

;;; :min for minimize

;;; :if-exists for always/never/thereis and finding such-that

;;; Note that we do not check for type conflict in the re-use of these

;;; variables.

(defvar *accum-var-alist*)

;;; Shared variables created by make-shared-binding.

;;; It's an alist of (name gensym-var <possibly other info>).

;;; Tipical use is FIRST-ITERATION-P.

(defvar *shared-bindings-alist*)

;;; Name of the block for this iterate form. Used in generating

;;; return statements.

(defvar *block-name*)

;;; The index of standard clauses (a discrimination tree). This is a

;;; defvar so that reloading doesn't clobber existing defs (though it

;;; will clobber those clauses that are defined in this file, of

;;; course).

(defvar *clause-info-index* (list :index))

(eval-when (:compile-toplevel)

;; This is so the variable has a value when we compile this file, since

;; the process of compilation results in actually setting things up.

(if (not (boundp '*clause-info-index*))

(setq *clause-info-index* (list :index))))

;;; An alist of lisp special forms and the functions for handling them.

;;; nil as function means leave form as-is.

(defparameter *special-form-alist*

'(;; First the special operators that every code walker must recognize

(block . walk-cddr)

(catch . walk-cdr)

(declare . walk-declare)

(eval-when . walk-cddr)

(flet . walk-flet)

(function . walk-function)

(go . nil)

(if . walk-cdr) ; also walk test form

(labels . walk-flet)

(let . walk-let)

(let* . walk-let)

(load-time-value . nil)

(locally . walk-cdr-with-declarations)

;(macrolet . walk-macrolet) ; uncomment to raise error

(multiple-value-call . walk-cdr)

(multiple-value-prog1 . walk-cdr)

(progn . walk-progn)

(progv . walk-cdr)

(quote . nil)

(return-from . walk-cddr)

(setq . walk-setq)

(symbol-macrolet . walk-cddr-with-declarations)

(tagbody . walk-tagbody)

(the . walk-cddr)

(throw . walk-cdr)

(unwind-protect . walk-cdr)

;; Next some special cases:

;; m-v-b is a macro, not a special form, but we want to recognize bindings.

;; Furthermore, Lispworks macroexpands m-v-b into some unknown m-v-BIND-call special form.

(multiple-value-bind . walk-multiple-value-bind)

;; Allegro treats cond as a special form, it does not macroexpand.

# allegro (cond . walk-cond)

;; Prior to 2005, CLISP expanded handler-bind into some

;; sys::%handler-bind syntax not declared as a special operator.

# clisp (handler-bind . walk-cddr) ; does not recognize clauses in handlers

;; A suitable generalization would be a pattern language that describes

;; which car/cdr are forms to be walked, declarations or structure.

;; Walk with-*-iterator ourselves in order to avoid macrolet warnings.

;; Note that walk-cddr-with-declarations won't walk the

;; package/hash-table descriptor argument, but it's good enough for now.

(with-package-iterator . walk-cddr-with-declarations)

(with-hash-table-iterator . walk-cddr-with-declarations)

;; Finally some cases where code compiled from the macroexpansion

;; may not be as good as code compiled from the original form:

;; -- and iterate's own expansion becomes more readable

(and . walk-cdr)

(ignore-errors . walk-cdr) ; expands to handler-bind in CLISP

(multiple-value-list . walk-cdr)

(multiple-value-setq . walk-cddr)

(nth-value . walk-cdr)

(or . walk-cdr)

(prog1 . walk-cdr)

(prog2 . walk-cdr)

(psetq . walk-setq)))

;;; For clauses that are "special" in the sense that they don't conform to the

;;; keyword-argument syntax of Iterate clauses.

(defvar *special-clause-alist* nil)

;;; These two are for conserving temporaries. *temps* is a list

;;; of temporaries that have already been created and given bindings.

;;; *temps-in-use* is a list of temporaries that are currently being used.

;;; See with-temporary, with-temporaries.

;;; This seems to stem from a time where it was more efficient to use

;;; (prog (temp)

;;; ... (setq temp #) ; somewhere deep inside the body

;;; (foo temp)

;;; (bar temp)

;;; ...)

;;; than using a local let deep inside that body, as in

;;; (tagbody ... (let ((temp #)) (foo temp) (bar temp)) ...)

;;; which may be be easier for compiler data flow and lifetime analysis.

(defvar *temps*)

(defvar *temps-in-use*)

;;; This is the environment, for macroexpand.

(defvar *env*)

;;; This is a list of information about drivers, for use by the NEXT

;;; mechanism.

(defvar *driver-info-alist*)

;;; This is used by the PREVIOUS mechanism.

(defvar *previous-vars-alist*)

;;; Loop labels

(defvar *loop-top*)

(defvar *loop-step*)

(defvar *loop-end*)

;;; Whether a label was used, to avoid generating them. This is so we don't

;;; get a warning from compilers that check for unused tags.

(defvar *loop-step-used?*)

(defvar *loop-end-used?*)

;;; Things that we should wrap the loop's body in

(defvar *loop-body-wrappers*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(eval-when (:compile-toplevel :load-toplevel :execute)

;;; Clause-info structures, which are put in the clause index.

(defstruct clause-info

function

keywords

req-keywords

doc-string

generator?)

;;; Driver-info structures, for information about driver variables--used by

;;; NEXT.

(defstruct driver-info

next-code

generator?

(used nil))

;;; Previous-info structures, used by the PREVIOUS mechanism.

(defstruct previous-info

var

save-info-list

code

(class :step))

(defstruct save-info

save-var

save-vars

iv-ref)

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Macros.

(eval-when (:compile-toplevel :load-toplevel :execute) ;; Allegro needs this

# nil ;; unused

(defmacro assertion (test)

`(if (not ,test) (bug "Assertion ~a failed" ',test)))

(defmacro augment (var stuff)

`(setf ,var (nconc ,var ,stuff)))

(defmacro prepend (stuff var)

`(setf ,var (nconc ,stuff ,var)))

) ;end eval-when

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; SharpL.

;;;

;;; the #L reader macro is an abbreviation for lambdas with numbered

;;; arguments, with the last argument being the greatest numbered

;;; argument that is used in the body. Arguments which are not used

;;; in the body are (declare ignore)d.

;;;

;;; e.g. #L(list !2 !3 !5) is equivalent to:

;;; (lambda (!1 !2 !3 !4 !5) (declare (ignore !1 !4)) (list !2 !3 !5))

(eval-when (:compile-toplevel :execute)

(defun sharpL-reader (stream subchar n-args)

(declare (ignore subchar))

(let* ((form (read stream t nil t))

(bang-vars (sort (bang-vars form) #'< :key #'bang-var-num))

(bang-var-nums (mapcar #'bang-var-num bang-vars))

(max-bv-num (if bang-vars

(reduce #'max bang-var-nums :initial-value 0)

0)))

(cond

((null n-args)

(setq n-args max-bv-num))

((< n-args max-bv-num)

(error "#L: digit-string ~d specifies too few arguments" n-args)))

(let* ((bvars (let ((temp nil))

(dotimes (i n-args (nreverse temp))

(push (make-bang-var (1 i)) temp))))

(args (mapcar #'(lambda (x) (declare (ignore x)) (gensym))

bvars))

(ignores (set-difference bvars bang-vars))

(decl (if ignores `(declare (ignore .,ignores)) nil))

(body (if (list-of-forms? form)

(if decl (cons decl form) form)

(if decl (list decl form) (list form))))

(subbed-body (sublis (pairlis bvars args) body)))

`#'(lambda ,args ,.subbed-body))))

(defun make-bang-var (n)

(intern (format nil "!~d" n)))

(defun list-of-forms? (x)

(and (consp x) (consp (car x))

(not (eq (caar x) 'lambda))))

(defun bang-vars (form)

(delete-duplicates (bang-vars-1 form '()) :test #'eq))

(defun bang-vars-1 (form vars)

(cond

((consp form)

(bang-vars-1 (cdr form)

(bang-vars-1 (car form) vars)))

((and (symbolp form) (bang-var? form)) (cons form vars))

(t vars)))

(defun bang-var? (sym)

(char= (char (symbol-name sym) 0) #\!))

(defun bang-var-num (sym)

(let ((num (read-from-string (subseq (symbol-name sym) 1))))

(if (not (and (integerp num) (> num 0)))

(error "#L: ~a is not a valid variable specifier" sym)

num)))

(defun enable-sharpL-reader ()

(set-dispatch-macro-character #\# #\L #'sharpL-reader))

;; According to CLHS, *readtable* must be rebound when compiling

;; so we are free to reassign it to a copy and modify that copy.

(setf *readtable* (copy-readtable *readtable*))

(enable-sharpL-reader)

) ; end eval-when

#|

;; Optionally set up Slime so that C-c C-c works with #L

# #.(cl:when (cl:find-package "SWANK") '(:and))

(unless (assoc "ITERATE" swank:*readtable-alist* :test #'string=)

(bind ((*readtable* (copy-readtable *readtable*)))

(enable-sharpL-reader)

(push (cons "ITERATE" *readtable*) swank:*readtable-alist*)))

;|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; The ITERATE macro.

(defmacro iterate (&body body)

"Jonathan Amsterdam's powerful iteration facility"

`(iter .,body))

(defmacro iter (&body body &environment env)

"Jonathan Amsterdam's powerful and extensible iteration facility,

providing multiple accumulation, generators, memory of previous

iterations, over 50 clauses to start with and a Lisp-like syntax.

Evaluate (iterate:display-iterate-clauses) for an overview of clauses"

(let* ((*env* env)

(*result-var* (genvar 'result))

(*type-alist* nil)

(*declare-variables* *always-declare-variables*)

(*bindings* nil)

(*internal-variables* nil)

(*previous-vars-alist* nil)

(*declarations* nil)

(*loop-body-wrappers* nil)

(*accum-var-alist* nil)

(*shared-bindings-alist* nil)

(*top-level?* t)

(*binding-context?* nil)

(*temps* nil)

(*temps-in-use* nil)

(*driver-info-alist* nil)

(*block-name* (if (symbolp (car body))

(pop body)

nil))

(*loop-top* (symbol-append 'loop-top- *block-name*))

(*loop-step* (symbol-append 'loop-step- *block-name*))

(*loop-end* (symbol-append 'loop-end- *block-name*))

(*loop-step-used?* nil)

(*loop-end-used?* nil))

(process-top-level-decls body)

(multiple-value-bind (body decls init-code steppers final-code final-prot)

(walk-list body)

(multiple-value-bind (init step)

(insert-previous-code)

(augment init-code init)

(augment steppers step))

(prepend (default-driver-code) body)

(let ((it-bod `(block ,*block-name*

(tagbody

(progn ,.init-code)

,*loop-top*

(progn ,.body)

,.(if *loop-step-used?* (list *loop-step*))

(progn ,.steppers)

(go ,*loop-top*)

,.(if *loop-end-used?* (list *loop-end*))

(progn ,.final-code))

,(if (member *result-var* *bindings* :key #'car)

*result-var*

nil))))

(wrap-form *loop-body-wrappers*

`(let* ,(nreverse *bindings*)

,.(if *declarations*

`((declare .,*declarations*)))

,.decls

,(if final-prot

`(unwind-protect ,it-bod .,final-prot)

it-bod)))))))

(defmacro defmacro-clause (clause-template &body body)

"Create your own iterate clauses"

(define-clause 'defmacro clause-template body nil))

(defmacro defmacro-driver (clause-template &body body)

"Create iterators which may also be used as generators"

(define-clause 'defmacro clause-template body t))

;;;;;;;;;;;;;;;;

(defun process-top-level-decls (clauses)

;; This sets *type-alist* to an alist of (var . type), and

;; sets *declare-variables* to t if such a declaration was seen.

(dolist (clause clauses)

(when (and (consp clause) (eq (car clause) 'declare))

(dolist (spec (cdr clause))

(cond

((eq (first spec) 'declare-variables)

(setq *declare-variables* t))

((or (eq (first spec) 'type) ; We don't do ftypes

;; FIXME recognize all shorthand type declarations

;; e.g. (declare ((unsigned-byte 8) x) etc.

;; -- but how to recognize type specifications?

(member (first spec) standard-type-symbols :test #'eq))

(let ((type (first spec))

(vars (cdr spec)))

(if (eq type 'type)

(setq type (pop vars)))

(dolist (var vars)

(push (cons var type) *type-alist*)))))))))

(defun default-driver-code ()

nil)

(defun wrap-form (wrappers form)

(if (consp wrappers)

(wrap-form (cdr wrappers)

(nconc (copy-list (car wrappers))

(list form)))

form))

(defun add-loop-body-wrapper (wrapper)

(push wrapper *loop-body-wrappers* ))

;(defun default-driver-code ()

; ;; Collect all non-generator code.

; ;; [Old version: Collect all code not explicitly invoked with NEXT.]

; (let ((code nil))

; ;; Put list in same order as clauses

; (setq *driver-info-alist* (nreverse *driver-info-alist*))

; (dolist (entry *driver-info-alist*)

; (let ((di (cdr entry)))

; (when (not (driver-info-generator? di))

; (assert (not (driver-info-used di)))

; (augment code (copy-list (driver-info-next-code di))))

; (if (and (driver-info-generator? di)

; (not (driver-info-used di)))

; (clause-warning "A generator was never used"))))

; code))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; The code walker.

(defun walk (form)

;; Returns the usual five things; body is a list of forms.

(cond

((atom form) ; symbol-macrolet must not expand into Iterate clauses

(list form))

((symbolp (car form))

(cond

;; The ordering of these checks is such that:

;; 1. We handle special operators that any Common Lisp code walker

;; must recognize.

;; 2. We handle some special cases like Allegro's cond

;; 3. Then we expand macros.

;; 4. Then only do we recognize Iterate clauses

;; -- which may thus be shadowed

;;

;; Note that implementations are permitted to let SPECIAL-OPERATOR-P

;; return T for any macros (e.g. CLISP for WHEN). Yet they must provide

;; a macroexpansion for these.

((special-form? (car form))

(walk-special-form form))

((macro-function (car form) *env*)

;; Some compilers (e.g. Lucid on Sparcs) treat macros differently at

;; compile-time; macroexpand does not expand them. We assume that if

;; this happens, macroexpand's second value is nil.

;; What do we do with the form in that case? This is actually a

;; very serious problem: if we don't walk it, we miss things, but if we

;; do walk it, we don't know how to walk it. Right now, we don't walk

;; it and print out a warning.

;; --Jeff Siskind says try binding *macroexpand-hook* to #'funcall.

(multiple-value-bind (ex-form expanded?)

(macroexpand-1 form *env*)

(cond

(expanded? (walk ex-form))

(t (clause-warning "The form ~a is a macro that won't expand. ~

It will not be walked, which means that Iterate clauses inside it will ~

not be seen."

form)

(list form)))))

((special-operator-p (car form))

(clause-warning "Iterate does not know how to handle the special form ~s~%~

It will not be walked, which means that Iterate clauses inside it will ~

not be seen." form)

(list form))

((starts-clause? (symbol-synonym (car form)))

(process-clause form))

(t ;; Lisp function call

(return-code-modifying-body #'walk-arglist (cdr form)

#L(list (cons (car form) !1))))))

((lambda-expression? (car form))

;; Function call with a lambda in the car

(multiple-value-bind (bod decs init step final final-prot)

(walk-fspec (car form))

(multiple-value-bind (abod adecs ainit astep afinal afinal-prot)

(walk-arglist (cdr form))

(values (list (cons bod abod)) (nconc decs adecs) (nconc init ainit)

(nconc step astep) (nconc final afinal)

(nconc final-prot afinal-prot)))))

# clisp ; some macros expand into ((setf foo) value other-args...)

;; reported by Marco Baringer on 24 Jan 2005

((typep form '(cons (cons (eql setf) *) *))

(apply #'walk-cdr form))

(t

(clause-error "The form ~a is not a valid Lisp expression" form))))

(defun walk-list (forms)

(walk-list-nconcing forms #'walk))

(defun walk-arglist (args)

(let ((*top-level?* nil))

(walk-list-nconcing args #'walk #L(if (is-iterate-clause? !1)

(list (prognify !2))

!2))))

(defun walk-fspec (form)

;; Works for lambdas and function specs in flet and labels.

;; FORM = (LAMBDA-or-name args . body)

;; We only walk at the body. The args are set up as internal variables.

;; Declarations are kept internal to the body.

(let* ((args (second form))

(body (cddr form))

(*top-level?* nil)

(*binding-context?* t)

(*internal-variables* (add-internal-vars args)))

(multiple-value-bind (bod decs init step final finalp)

(walk-list body)

(values `(,(first form) ,args ,.decs ,.bod) nil init step final

finalp))))

(defun walk-list-nconcing (list walk-fn

&optional (body-during #L!2))

(let (body-code decls init-code step-code final-code finalp-code)

(dolist (form list)

(declare (optimize (speed 0)))

(multiple-value-bind (body decs init step final finalp)

(funcall walk-fn form)

(augment decls decs)

(augment init-code init)

(augment body-code (funcall body-during form body))

(augment step-code step)

(augment final-code final)

(augment finalp-code finalp)))

(values body-code decls init-code step-code final-code

finalp-code)))

(defun return-code-modifying-body (f stuff mod-f)

(declare (optimize (speed 0)))

(multiple-value-bind (bod decs init step final finalp)

(funcall f stuff)

(values (funcall mod-f bod) decs init step final finalp)))

(defun add-internal-var (var)

;; VAR can be a symbol or a list (symbol ...).

(cons (if (consp var) (car var) var) *internal-variables*))

(defun add-internal-vars (vars)

;; VARS could be a lambda-list, a list of LET bindings, or just a list of

;; variables; all will work.

(nconc (lambda-list-vars vars) *internal-variables*))

(defun lambda-list-vars (lambda-list)

;; Return the variables in the lambda list, omitting keywords, default

;; values.

(mapcan #'(lambda (thing)

(cond

((consp thing)

(if (consp (car thing)) ; this is a full keyword spec

(list (second (car thing)))

(list (car thing))))

((not (member thing lambda-list-keywords))

(list thing))))

lambda-list))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Special forms.

(defun special-form? (symbol)

;; special-operator-p doesn't work in Lucid--it returns NIL for let, for

;; example. Plus, we want to catch Iterate special clauses.

(assoc symbol *special-form-alist*))

(defun walk-special-form (form)

(let ((*clause* form)

(func (cdr (assoc (car form) *special-form-alist*))))

(if (null func) ; there's nothing to transform

(list form)

(apply func form))))

# nil

(defun walk-identity (&rest stuff)

(list stuff))

(defun walk-cdr (first &rest stuff)

;; This is for anything where only the car isn't to be walked.

(return-code-modifying-body #'walk-arglist stuff #L(list (cons first !1))))

(defun walk-cddr (first second &rest stuff)

;; This is for anything where the first two elements aren't to be walked.

(return-code-modifying-body #'walk-arglist stuff

#L(list (cons first (cons second !1)))))

(defun walk-progn (progn &rest stuff)

;; The only difference between this and walk-cdr is that *top-level* is not

;; bound. This is so macros can return PROGNs of things. It's exactly like

;; the definition of "top-level" in lisp.

;; (Also, just for looks, this returns nil if the progn is empty.)

(return-code-modifying-body #'walk-list stuff

#L(if (null !1)

nil

(list (cons progn !1)))))

(defun walk-setq (setq &rest things)

;; Walk every other thing.

(let ((*top-level?* nil)

(i 1)

body-code decls init-code step-code final-code finalp-code)

(dolist (thing things)

(if (oddp i)

(push thing body-code)

(multiple-value-bind (body decs init step final finalp)

(walk thing)

(augment decls decs)

(augment init-code init)

(push (prognify body) body-code)

(augment step-code step)

(augment final-code final)

(augment finalp-code finalp)))

(incf i))

(values (list (cons setq (nreverse body-code)))

decls init-code step-code final-code finalp-code)))

(defun walk-function (function form)

(if (lambda-expression? form)

(return-code-modifying-body #'walk-fspec form #L(list

(list function !1)))

(list (list function form))))

(defun walk-declare (&rest declaration)

;; DECLARE is a declaration, and should be put in the declaration

;; section of the loop. Declarations are only allowed at top-level,

;; except that they are allowed within binding environments, in which case

;; they apply only to that binding environment.

# symbolics (setq declaration (copy-list declaration))

(if (or *top-level?* *binding-context?*)

(return-code :declarations (list declaration))

(clause-error "Declarations must occur at top-level, or inside a ~

binding context like let or multiple-value-bind.")))

(defun walk-let (let bindings &rest body)

;; The bindings or body may contain iterate clauses.

;; Important: the decls go inside this let, not at top-level.

;; It is an error to use a variable in the let bindings as the

;; target of an accumulation (i.e. INTO), because iterate will try

;; to make a top-level binding for that variable. The same goes for

;; other variables that might be so bound.

(let ((*top-level?* nil))

(multiple-value-bind (binds b-decls b-init b-step b-final b-finalp)

(walk-let-bindings let bindings)

(let ((*binding-context?* t)

(*internal-variables* (add-internal-vars binds)))

(multiple-value-bind (bod decls init step final finalp)

(walk-list body)

(return-code :declarations b-decls

:initial (nconc b-init init)

:body (list `(,let ,binds ,.decls ,.bod))

:step (nconc b-step step)

:final (nconc b-final final)

:final-protected (nconc b-finalp finalp)))))))

(defun walk-let-bindings (let bindings)

(if (eq let 'let)

(walk-list-nconcing bindings #'walk-let-binding #L(list !2))

(walk-let*-bindings bindings)))

(defun walk-let*-bindings (bindings)

;; We have to do this one binding at a time, to get the variable scoping

;; right.

(if (null bindings)

nil

(multiple-value-bind (bod decls init step final finalp)

(walk-let-binding (car bindings))

(let ((*internal-variables* (add-internal-var (car bindings))))

(multiple-value-bind (bod1 decls1 init1 step1 final1 finalp1)

(walk-let*-bindings (cdr bindings))

(values (cons bod bod1) (nconc decls decls1) (nconc init init1)

(nconc step step1) (nconc final final1)

(nconc finalp finalp1)))))))

(defun walk-let-binding (binding)

(if (consp binding)

(multiple-value-bind (bod decls init step final finalp)

(walk (second binding))

(values (list (first binding) (prognify bod)) decls init step final

finalp))

binding))

(defun walk-multiple-value-bind (mvb vars expr &rest body)

;; Important: decls go inside the mvb, not at top-level. See

;; walk-let for binding subtleties.

(declare (ignore mvb))

(let ((*top-level?* nil))

(multiple-value-bind (ebod edecls einit estep efinal efinalp)

(walk expr)

(let ((*binding-context?* t)

(*internal-variables* (add-internal-vars vars)))

(multiple-value-bind (bod decls init step final finalp)

(walk-list body)

(return-code :declarations edecls

:initial (nconc einit init)

:body (list `(multiple-value-bind ,vars

,(prognify ebod)

,.decls ,.bod))

:step (nconc estep step)

:final (nconc efinal final)

:final-protected (nconc efinalp finalp)))))))

(defun walk-flet (flet bindings &rest body)

;; For FLET or LABELS. We don't worry about the function bindings.

(let ((*top-level?* nil))

(multiple-value-bind (binds b-decls b-init b-step b-final b-finalp)

(walk-list-nconcing bindings #'walk-fspec #L(list !2))

(let ((*binding-context?* t))

(multiple-value-bind (bod decls init step final finalp)

(walk-list body)

(return-code :declarations b-decls

:initial (nconc b-init init)

:body (list `(,flet ,binds ,.decls ,.bod))

:step (nconc b-step step)

:final (nconc b-final final)

:final-protected (nconc b-finalp finalp)))))))

(defun walk-cdr-with-declarations (first &rest stuff) ; aka walk-locally

;; Set *top-level?* false (via walk-arglist).

;; Note that when *top-level?* is false, walk won't yield declarations

;; because walk-declare errors out since all forms with

;; *declaration-context?* true keep them local (that is, in walk-let,

;; walk-flet and walk-multiple-value-bind b-decls/edecls are always NIL).

;; Ignoring code-movement issues, this approach should be fine.

(let* ((forms (member 'declare stuff :key #L(if (consp !1) (car !1))

:test-not #'eq))

(decls (ldiff stuff forms)))

(return-code-modifying-body #'walk-arglist forms

#L(list (cons first (nconc decls !1))))))

(defun walk-cddr-with-declarations (first second &rest stuff)

(let* ((forms (member 'declare stuff :key #L(if (consp !1) (car !1))