From segre@cs.cornell.edu Sun Nov  6 11:17:15 1988
Received: from cs.wisc.edu by steves.cs.wisc.edu; Sun, 6 Nov 88 11:13:41 CST
Received: from CU-ARPA.CS.CORNELL.EDU by cs.wisc.edu; Sun, 6 Nov 88 11:09:55 CST
Received: from BAAL.CS.CORNELL.EDU by cu-arpa.cs.cornell.edu (5.59/4.30)
	id AA00228; Sun, 6 Nov 88 12:01:40 EST
Date: Sun, 6 Nov 88 11:58:08 EST
From: segre@cs.cornell.edu (Alberto M. Segre)
Message-Id: <8811061658.AA03972@baal.cs.cornell.edu>
Received: by baal.cs.cornell.edu (3.2/1.05)
	id AA03972; Sun, 6 Nov 88 11:58:08 EST
To: bennett@uicsl.csl.uiuc.edu, bharat@uicsl.csl.uiuc.edu,
        chien@uicsl.csl.uiuc.edu, cmh@purdue.edu, dejong@uicslsw.csl.uiuc.edu,
        dyer@stilton.cs.wisc.edu, gervasio@uicsl.csl.uiuc.edu,
        jbates@pt.cs.cmu.edu, jfc@cs.cornell.edu,
        kearney%cs.uiowa.edu@relay.cs.net, marzullo@cs.cornell.edu,
        mooney@cs.utexas.edu, nealr@caen.engin.umich.edu, ororke@ics.uci.edu,
        pangrle@bears.ucsb.edu, pazzani@ics.uci.edu,
        pollack@cis.ohio-state.edu, reinke@uicsl.csl.uiuc.edu,
        ropelato%itncisca.BITNET@cu-arpa.cs.cornell.edu, segre@cs.cornell.edu,
        shavlik, stepp@uicsl.csl.uiuc.edu, tanimoto@june.cs.washington.edu,
        tgd@cs.orst.edu, whitehal@uicsl.csl.uiuc.edu
Status: R

#	This is a shell archive.
#	Remove everything above and including the cut line.
#	Then run the rest of the file through sh.
#----cut here-----cut here-----cut here-----cut here----#
#!/bin/sh
# shar:    Shell Archiver
#	Run the following text with /bin/sh to create:
#	Notes
#	for.lsp
#	mexp.lsp
#	for-tran.el
#	mv+
# This archive created: Sun Nov  6 11:57:15 1988
cat << \SHAR_EOF > Notes
Common Lisp FOR Macro Release Notes.

Mail bug reports to segre@gvax.cs.cornell.edu

=====
November 3, 1988:

Added flag *FOR-MACRO-REDUCE-FLAG* to control use of REDUCE vs.  APPLY
in arithmetic expansion.  Initially set to nil for speed.  The loss
occurs if the length of the list in question exceeds
call-arguments-limit for your lisp.  In such cases, it would be best to
change APPLY to REDUCE (by setting *FOR-MACRO-REDUCE-FLAG*) for all
three of +, MIN, and MAX in MAKE-ARITHMETIC-FORM. 

=====
July 21, 1988:

Enough of you have complained about losing the old-style (non
keyword-package keywords) that they will not be phased out. Instead,
as of this release, they will be supported ONLY if you set the
variable FOR::*FOR-MACRO-KEYWORD-STYLE* to NIL (defaults to T).

FOR::*FOR-MACRO-EXPANSION-WARNING* no longer exists; instead the old
style keywords are supported (without printing a warning) by
preprocessing the form to replace them with the new style. Using the
keyword-package keywords results in slightly reduced macroexpansion
time.

This version now includes a (require 'mexp "your-path-goes-here").
Make sure you edit this path and supply the location of the mexp file.

I am including the GNU emacs for-tran.el file for those of you who are
still wanting to convert existing files to the new-style keywords. I
am also including a nice little shell script to handle changing
extensions (e.g., from ".lsp" to ".lisp"). You install it somewhereon
your Unix path, and then type:
	% mv+ ".lsp" ".lisp" *.lsp
to change all ".lsp"s to ".lisp"s.

Finally, this version features a bug fix.
Old version of FOR would return (D) when eval'ing the form:
  (for x :on '(a b c d) :until (eq (car x) 'c) :finally (return x))
instead of the more obvious (C D). The similar form:
  (for x :in '(a b c d) :until (eq x 'c) :finally (return x))
was (correctly) returning C. Kudos to Ray Mooney for finding the bug.

I am still maintaining mailing lists for homework problems/machine
problems/exam questions for introductory AI courses. If you want to be
added to that distribution list, please drop me a note. Submissions
are encouraged!

I am also distributing a GNU emacs to common lisp interface that
provides some neat features such as in-editor macro expansion, on-line
common lisp documentation, evaling/compiling functions from the
editor, function name cross-indexing, and so on. If you are
interested, drop me a line for that as well.

=====
July 14, 1988:

A few bug fixes that snuck thru in the last release.

1. BY and :BY now default properly.
2. :THEREIS forms expanding into FIND-IFs now expand correctly.
This is a new release of the Common Lisp FOR macro. Along with a few bug
fixes, this release supports the use of keywords from the Common Lisp keywords
package in the FOR macro. Later releases will no longer support the original
keywords (e.g., in, on, as, collect, etc) in favor of the new style keywords
(e.g., :in, :on, :as, :collect, etc). For now, both versions are supported,
although old-style keywords will print a warning at expansion time (can be
turned off by setting for-macro::*for-macro-expansion-warning* to nil).

Additional features supported are the use of WHILE, UNTIL,
REPEATWHILE, REPEATUNTIL as well as BIND and FOR in the car position
of a macro form. When in this car position, these keywords appear
WITHOUT the leading ":"

The release consists of three files, shar'd together. To unpack, you must
cut below and pass the rest of this message to /bin/sh. Along with the new
for macro, the following files are supplied:

   mexp.lsp -- a Symbolics-style read-macroexpand-print top-level loop.
               useful for interactive debugging of your forms.

   for-tran.el -- GNU emacs file conversion facility. Crude, but works.
                  Changes old-style keywords to new-style keywords
                  using query-replace to make sure it doesn't do
		  anything stupid.

Bug reports to me. Let me know if you are using this or if you prefer
to be removed from my mailing list.

I also have available a GNU/Common Lisp interface that works with KCL
(but should also work with any other Common Lisp) iff you are
interested. It supports some of the more useful Symbolics environment
features. 

=====
July 4, 1988:

Bug discovered in expansion of FINALLY, INITIALLY, and BIND. Order of
expressions in the expansion was sometimes the reverse of the original
ordering. The problem was especially noticeable when you had something
like FINALLY (blah)(return 'fooey) -- the expansion would invert the
order and blah would never get done.

=====
October 22, 1987:

FOR can now be used more easily from packages other than USER. All you have
to do in your package is to say (use-package 'USER) to get full use of the
FOR macro.

=====
June 30, 1987:

Bug corrected in SUM => REDUCE expansion.

==== Cut Here ========= Cut Here ========= Cut Here ========= Cut Here =====
SHAR_EOF
cat << \SHAR_EOF > for.lsp
;;;   -*- Syntax: Common-Lisp; Package: USER; Base: 10; Mode: LISP -*-    ;;;
;;;                                                                       ;;;
;;;    Copyright (c) 1987,88 -- Alberto M. Segre, Cornell University      ;;;
;;;                                                                       ;;;
;;;  May be redistributed freely provided this copyright notice remains.  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Common lisp iteration macro. Inspired by the Interlisp FOR clisp
;;; macro (old habits die hard!). Make sure to change the path for the
;;; require below to reflect installation directories at your site.

(provide 'for)
(require 'mexp "/usr/u/cap/utils/mexp")

(defvar *for-macro-date* "November 3, 1988")

;;; A FOR takes zero or more variable clauses, separated by the :AS
;;; keyword. In addition, it is possible to create extra variables
;;; with the :BIND keyword. With zero FOR variables, there must be at
;;; least one :BIND variable: in these cases the FOR keyword can be
;;; dropped, and the macro invoked using BIND in the car position.
;;; WHILE, UNTIL, REPEATWHILE, and REPEATUNTIL can also be used alone
;;; in the car position of a form.  Here are some examples:

;;;  (for x :in list 
;;;       :as y :on list
;;;       :as z :from 1 :to 10 :by 2
;;;       :collect (list x y z))
;;;  (for x :from 1
;;;       :bind z (w 10) y
;;;       :initially (setq y (* w 2)) 
;;;       :do (print x)
;;;       :finally (print y))
;;;  (bind x :while (setq x (pop queue))
;;;        :do (print x))
;;;  (repeatuntil (null list)
;;;               :do (pop list))

;;; Variables using the keyword :IN will iterate over the car's of
;;; their argument.

;;; Variables using the keyword :ON williterate over the cdr's of their
;;; argument.

;;; Variables using the keyword :FROM take a range specified using :TO
;;; and :BY, both of which are optional.

;;; Each FOR can contain any number of clauses beginning with the
;;; following keywords:
;;;   :INITIALLY clauses to be executed before binding FOR variables.
;;;   :WHEN/:UNLESS filters to censor execution of the body this time thru.
;;;   :WHILE/:UNTIL termination conditions checked before the body.
;;;   :REPEATWHILE/:REPEATUNTIL termination conditions checked after the body.
;;;   :FINALLY clauses to be executed on exiting; explicit return allowed.

;;; In addition, each FOR takes one and only one body keyword:
;;;   :DO execute body, always return nil.
;;;   :JOIN execute body, splice together results.
;;;   :COLLECT execute body, return list of results.
;;;   :THEREIS return value of first FOR variable where body is first t.
;;;   :ALWAYS return t if body always t; terminates at first failure.
;;;   :NEVER return t if body always nil; terminates at first failure.
;;;   :MAX/:MIN execute body, return max/min of results.
;;;   :SUM execute body, return sum of results.
;;;   :COUNT execute body, return number of times body evaluates to t.

;;; An effort is made to expand to mapping functions (mapcar, mapc,
;;; mapcan, maplist, mapl, mapcon), sequence functions (every, notany,
;;; count-if, find-if), or applications of arithmetic functions (+,
;;; max, min) if at all possible.  Otherwise, FOR expands to a do.
;;; Note that the legality of each type of expansion can be controlled
;;; by setting the variables *FOR-MACRO-xxx-EXPANSION-FLAG*, where xxx
;;; is one of MAP, SEQUENCE, or ARITHMETIC. By setting these all to
;;; nil, a FOR will always expand to a do.

;;; Finally, note that manipulations (destructive or otherwise) of the
;;; range of the loop from inside the FOR are not wise: since the
;;; exact expansion form depends on the form, you could really loose
;;; this way.  If you must manipulate the range of the iteration, set
;;; your own iterative variable. You can then feel free to manipulate
;;; your queue as you wish.

;;; Set up FOR package. Note use of nickname to provide compatibility
;;; with earlier versions of FOR. Make sure all of the keywords (even
;;; the old-style ones) are available from the USER package before
;;; switching to the new FOR package.

(export '(for bind as in on from by to initially when 
	      unless while until repeatwhile repeatuntil 
	      do join collect thereis always never 
	      max min sum count finally))
(in-package 'FOR :use '(LISP USER) :nicknames '(FOR-MACRO))

;;; *FOR-MACRO-CAR-SYMBOLS* contains a list of all of the keywords
;;; that are allowed to appear as the car of a FOR form. These come
;;; from the USER package.

(defvar *for-macro-car-symbols* 
  '(for bind while until repeatwhile repeatuntil))

;;; *FOR-MACRO-KEYWORD-STYLE* when set to nil permits use of old-style
;;; non keyword package keywords. This causes an extra pass thru the
;;; macro to replace the old style keywords with the new style
;;; keywords.

(defvar *for-macro-keyword-style* t)

;;; *FOR-MACRO-KEYWORDS* contains a list of all of the keywords
;;; recognized by the FOR expansion mechanism. This list is used to
;;; drive the parser.

(defvar *for-macro-keywords* 
  '(for :bind :as :initially :when :unless
	:while :until :repeatwhile :repeatuntil
	:do :join :collect :thereis :always :never
	:max :min :sum :count :finally))

;;; *FOR-MACRO-OLD-KEYWORDS* contains a list of the old-style non
;;; keyword-package keywords. Use of these is enabled by setting
;;; *FOR-MACRO-KEYWORD-STYLE* to nil.

(defvar *for-macro-old-keywords* 
  '(for bind as initially when unless 
	 while until repeatwhile repeatuntil 
	 do join collect thereis always never 
	 max min sum count finally))

;;; *FOR-MACRO-RANGE-KEYWORDS* contains a list of keywords used to
;;; specify ranges of the iterative variables. Likewise,
;;; *FOR-MACRO-OLD-RANGE-KEYWORDS* contains the old-style equivalents.
;;; These lists are used to convert old to new style keywords.

(defvar *for-macro-range-keywords* '(:in :on :from :by :to))
(defvar *for-macro-old-range-keywords* '(in on from by to))

;;; *FOR-MACRO-xxx-EXPANSION-FLAG* controls the expansion of the FOR
;;; into this kind of form. If your system is particularly slow with
;;; some kind of form, you may want to prohibit the system from
;;; expanding into that kind of form. These should probably all be t,
;;; unless your system has an incredibly fast do and lousy mapping
;;; functions.

(defvar *for-macro-map-expansion-flag* t)
(defvar *for-macro-sequence-expansion-flag* t)
(defvar *for-macro-arithmetic-expansion-flag* t)

;;; *FOR-MACRO-REDUCE-FLAG* controls the use of REDUCE vs. APPLY in
;;; arithmetic expansions. It is initially set to nil, thus preferring
;;; to use APPLY.  Note if there are more arguments to sum, min or max
;;; than the value of call-arguments-limit you lose.  The solutionis
;;; to expand into a REDUCE rather than an APPLY of the appropriate
;;; function; this tends to slow things down a lot.

(defvar *for-macro-reduce-flag* nil)

;;; BIND is one of the trivial forms of the FOR, where the user
;;; controls his own termination conditions. BIND can be used along
;;; with FOR variables, or alone. When used alone, the initial FOR can
;;; be dispensed with, and is added explicitly by this form. WHILE,
;;; UNTIL, REPEATWHILE, REPEATUNTIL are handled in a similar fashion.

(defmacro bind (&body body)
  (macroexpand `(for :bind ,@body)))

(defmacro while (&body body)
  (macroexpand `(for :while ,@body)))

(defmacro until (&body body)
  (macroexpand `(for :until ,@body)))

(defmacro repeatwhile (&body body)
  (macroexpand `(for :repeatwhile ,@body)))

(defmacro repeatuntil (&body body)
  (macroexpand `(for :repeatuntil ,@body)))

;;; FOR is the expansion function. It dissects the FOR expression,
;;; parsing it into several different lists. The configurations of
;;; these lists determines what the form should expand to.

(defmacro for (&body form)
  (prog ((keyword 'for) (original form) clause variables binds 
	 initials filters quits body postquits finals types)
;;;
;;; If the old-style (non-keyword package) symbols are being used then
;;; we must run preprocessor to convert them to the new kind.
;;;
	(unless *for-macro-keyword-style*
	  (setq form (change-keyword-style form)))
;;;
;;; Make one pass through the FOR and parse it into different types of
;;; clauses. Note that the FOR clause may be nil if this is a
;;; variable-less for (eg, one that uses BIND variables).
;;;
	PARSER
	(multiple-value-setq (clause form)
			     (parse-for-clause form))
	(case keyword
	  ((for :as) (when clause (push clause variables)))
	  (:bind (push clause binds))
	  (:initially (push clause initials))
	  ((:when :unless) (push (cons keyword clause) filters))
	  ((:while :until) (push (cons keyword clause) quits))
	  ((:do :join :collect :thereis :always :never 
		:max :min :sum :count)
	   (cond (body (error "More than one body in FOR expansion."))
		 (t (setq body (cons keyword clause)))))
	  ((:repeatwhile :repeatuntil) 
	   (push (cons keyword clause) postquits))
	  (:finally (push clause finals))
	  (t (error "Unparsable FOR keyword: ~S." keyword)))
	(when (and (setq keyword (pop form)) form) 
	  (go PARSER))
;;;
;;; Make sure there is a body in this construct (users often forget
;;; the body keyword in a while). It is possible to build a legal FOR
;;; without a body, so just print a warning message.
;;;
	(unless body
	  (format t "~&;; Warning: FOR construct lacks body: ~&  ~S" 
		  (cond (variables (cons 'for original))
			(t original))))
;;;
;;; Reverse the order of the clauses that were constructed with push.
;;; Note that we have to remove one level of nesting from some of the
;;; lists where the syntax there is not quite as uniform as the rest of
;;; the FOR statement.
;;;
        (setq variables (nreverse (parse-variable-clauses variables)))
        (setq binds (nreverse (mapcan #'nreverse binds)))
	(setq initials (nreverse (mapcan #'nreverse initials)))
	(setq filters (nreverse filters))
	(setq quits (nreverse quits))
	(setq postquits (nreverse postquits))
	(setq finals (nreverse (mapcan #'nreverse finals)))
;;;
;;; How many types (:IN :ON :FROM) of variables are in this form?
;;;
        (mapc #'(lambda (var-form) 
		  (pushnew (cadr var-form) types)) 
	      variables)
;;;
;;; Determine what this expands to and call the appropriate expansion
;;; form. Simple cases go to mapping functions (mapcar, mapc, mapcan,
;;; maplist, mapl, mapcon), sequence forms (every, notany), quittable
;;; forms (count-if, find-if), or arithmetic forms (+, max, min).
;;; Everything else goes to a do.
;;;
	(return
	 (wrap-bind-form 
	  binds initials
;;;
;;; Only one type of variable, and it must be one of types (:IN :ON).
;;; Body is one of (:DO :JOIN :COLLECT): no finals or either type of
;;; quit form is allowed.
;;;
	  (cond ((and *for-macro-map-expansion-flag*
		      (null (cdr types))
		      (member (car types) '(:in :on) :TEST #'eq)
		      (member (car body) 
			      '(:do :join :collect)
			      :TEST #'eq)
		      (not (or quits finals postquits)))
		 (make-map-form variables body filters (car types)))
;;;
;;; Only one type of variable, and it must be of type :IN. Body is one
;;; of (:ALWAYS :NEVER :COUNT :THEREIS): no finals, or either type of
;;; quit form is allowed. Also note that :COUNT and :THEREIS should
;;; expand into find-if and count-if only if there is only one FOR
;;; variable.
;;;
		((and *for-macro-sequence-expansion-flag*
		      (null (cdr types))
		      (eq (car types) :in)
		      (member (car body) 
			      '(:always :never :count :thereis) 
			      :TEST #'eq)
		      (or (not (member (car body) 
				       '(:count :thereis)))
			  (null (cdr variables)))
		      (not (or quits finals postquits)))
		 (make-sequence-form variables body filters))
;;;
;;; Only one variable, and it must be of type :IN. Body is one of
;;; (:SUM :MAX :MIN): no finals, or either type of quit form is
;;; allowed.  Also, note that the body must simply be the variable
;;; name.
;;;
		((and *for-macro-arithmetic-expansion-flag*
		      (null (cdr variables))
		      (eq (car types) :in)
		      (member (car body) '(:sum :max :min) 
			      :TEST #'eq)
		      (not (or quits finals postquits)))
		 (make-arithmetic-form variables body filters))
;;;
;;; If all else fails, expand to a do.
;;;
		(t 
		 (make-do-form
		  variables body filters quits postquits finals)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Convert old-style keywords to keyword package ones.

(defun change-keyword-style (form)
  (mapc #'(lambda (new old)
	    (nsubstitute new old form))
	*for-macro-keywords*
	*for-macro-old-keywords*)
  (mapc #'(lambda (new old)
	    (nsubstitute new old form))
	*for-macro-range-keywords*
	*for-macro-old-range-keywords*)
  form)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; PARSE-FOR-CLAUSE returns the first clause in form, up to the next
;;; keyword or the end of form. It also returns (using multiple-values)
;;; what's left of form.

(defun parse-for-clause (form &optional (stoppers *for-macro-keywords*) clause)
  (cond ((or (null form)
	     (member (car form) stoppers :TEST #'eq))
	 (values (nreverse clause) form))
	(t (parse-for-clause (cdr form) stoppers (cons (car form) clause)))))

;;; PARSE-VARIABLE-CLAUSES reformats the varible clauses so they have
;;; some sort of uniformity. Each reformatted entry looks like
;;;   (x :IN list) (x :ON list) (x :FROM (start end incr))
;;; Note that this is the function that handles inserting default values
;;; for the increment field of a from variable. It also recursively
;;; macroexpands the range arguments of the variables.

(defun parse-variable-clauses (variables)
  (mapcar 
   #'(lambda (variable)
       (case (cadr variable)
	 ((:in :on)
	  `(,(car variable) 
	    ,(cadr variable)
	    ,(macroexpand (caddr variable))))
	 (:from
	  `(,(car variable) :from
	    (,(macroexpand (getf (cdr variable) :from nil))
	     ,(macroexpand (getf (cdr variable) :to nil))
	     ,(macroexpand (getf (cdr variable) :by 1)))))
	 (t 
	  (error "Unrecognized variable keyword ~S in FOR expansion." 
		 (cadr variable)))))
   variables))

;;; REEXPAND is used to recursively macroexpand forms during expansion.
;;; It returns a new list, suitable for destructive splicing without
;;; fear of reprisal.

(defun reexpand (form)
  (mapcar #'(lambda (element) (macroexpand element)) form))

;;; EXTRACT-VARIABLE-NAMES takes a variable list as produced by
;;; parse-variable-clauses and returns a list of all of the variable
;;; names.

(defun extract-variable-names (variables)
  (mapcar #'(lambda (variable) (car variable)) variables))

;;; EXTRACT-VARIABLE-RANGES takes a variable list as produced by
;;; parse-variable-clauses and returns a list of all of the variable
;;; ranges.

(defun extract-variable-ranges (variables)
  (mapcar #'(lambda (variable) (caddr variable)) variables))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; WRAP-BIND-FORM returns form wrapped in either a let or a progn that
;;; handles the binds and initials. Note that the initialization forms
;;; of the binds must be recursively expanded.

(defun wrap-bind-form (binds initials form)
  (cond (binds
	 `(let 
           ,(mapcar #'(lambda (var)
			(cond ((atom var) var) 
			      (t `(,(car var) ,(macroexpand (cadr var))))))
		    binds)
	   ,.(reexpand initials)
	   ,form))
	(initials
	 `(progn ,.(reexpand initials) ,form))
	(t form)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAKE-BODY creates the body of the iterative form. If there are
;;; filters, create a cond that returns flush-form if the filters are
;;; not met. nest-result causes an extra list to be wrapped around the
;;; body so results can be spliced together. progn-wrap wraps the body
;;; in a progn for pushing onto a result accumulation list. The form
;;; returned is suitable for splicing destructively.

(defun make-body (body &optional (filters nil) 
		       &key (nest-result nil) 
		            (progn-wrap nil) 
			    (flush-form nil))
  (cond (filters 
	 `((cond ,.(mapcar #'(lambda (clause)
			       (case (car clause)
				 (:when
				  `((not (and ,.(reexpand (cdr clause)))) 
				    ,flush-form))
				 (:unless
				  `((or ,.(reexpand (cdr clause))) 
				    ,flush-form))))
			   filters)
		 ,(cond (nest-result
			 `(t (list (progn ,.(reexpand (cdr body))))))
			(progn-wrap 
			 `(t (progn ,.(reexpand (cdr body)))))
			(t `(t ,.(reexpand (cdr body))))))))
	(t (cond (nest-result `((list (progn ,.(reexpand (cdr body))))))
		 (progn-wrap `((progn ,.(reexpand (cdr body)))))
		 (t (reexpand (cdr body)))))))
	

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAKE-MAP-FORM expands into a mapping function. There are only two
;;; special things we need to worry about. First, we need to make sure
;;; we call macroexpand recursively as we construct the body of the
;;; mapping function. This allows for nested fors. Second, since mapc
;;; and mapl are brain-damaged in common-lisp, we wrap the entire form
;;; in an extra progn that allows us to return nil for these two forms.

(defun make-map-form (variables body filters type)
  (case (car body)
    (:do `(progn
	    ( ,(case type
		 (:in 'mapc)
		 (:on 'mapl))
	      (function (lambda ,(extract-variable-names variables)
			  ,.(make-body body filters)))
	      ,.(extract-variable-ranges variables)) 
	    nil))
    (:join
     `( ,(case type
	   (:in 'mapcan)
	   (:on 'mapcon))
	(function (lambda ,(extract-variable-names variables)
		    ,.(make-body body filters)))
	,.(extract-variable-ranges variables)))
    (:collect
     `( ,(case type
	   (:in (cond (filters  'mapcan)
		      (t        'mapcar)))
	   (:on (cond (filters  'mapcon)
		      (t        'maplist))))
	(function (lambda ,(extract-variable-names variables)
		    ,.(make-body body filters 
				 :nest-result filters)))
	,.(extract-variable-ranges variables)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAKE-SEQUENCE-FORM expands an :ALWAYS, :NEVER, :COUNT, or :THEREIS
;;; with only :IN variables and no quits into an every or a notany.
;;; This is very similar to a map function, but a bit more
;;; restrictive. Note that if we are building an :ALWAYS, we need to
;;; return a non-nil flush form from the body when the filters aren't
;;; met, so that the iteration is not mistakenly aborted. For the
;;; others, a nil flush-form works fine. Finally, note that with these
;;; forms, the iteration may terminate prematurely as soon as the
;;; outcome is known.

(defun make-sequence-form (variables body filters)
  `( ,(case (car body)
	(:always   'every)
	(:never    'notany)
	(:count    'count-if)
	(:thereis  'find-if))
     (function (lambda ,(extract-variable-names variables)
		 ,.(make-body body filters 
			      :flush-form (when (eq (car body) :always) t))))
     ,.(extract-variable-ranges variables)))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAKE-ARITHMETIC-FORM expands a :MAX, :MIN or :SUM of one and only
;;; one :IN variable into an apply of +, max or min. Note that if the
;;; body is simply the same thing as the sole variable and there are
;;; no filters, you can apply the arithmetic function directly to the
;;; variable name.  The ugly case is when you have some filters or
;;; when you are not simply applying the arithmetic form to the loop
;;; variable directly.  In these cases, you need to make two complete
;;; passes thru the list, once collecting the filtered intermediate
;;; results, and once combining (via min, max or +) the intermediate
;;; results to produce the end result.

(defun make-arithmetic-form (variables body filters)
  `( ,(cond (*for-macro-reduce-flag* 'reduce)
	    (t 'apply))
     ,(case (car body)
	(:sum    '#'+)
	(:max    '#'max)
	(:min    '#'min))
     ,.(cond ((or filters 
		  (not (equal (cdr body)
			      (extract-variable-names variables))))
	      `(,(make-map-form 
		  variables `(:collect ,.(cdr body)) filters :in)))
	     (t (extract-variable-ranges variables)))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAKE-DO-FORM expands anything else into a do. In most lisps this
;;; should be a faster, more natural, form for iteration than a prog. Note
;;; that there is some element of dirt in handling iteration on the car
;;; of a form (requires using an extra iterative variable).
  
(defun make-do-form (variables body filters quits postquits finals)
  (let ((var-forms nil)
	(init-forms nil)
	(end-test-forms nil)
	(return-forms (make-do-return-form body filters))
	(final-forms (reexpand finals)))
    `(do 
;;;
;;; Construct the variable list first.
;;;
      (,.(progn 
	   (multiple-value-setq (var-forms init-forms end-test-forms)
				(make-do-variable-forms variables))
	   var-forms)
       ,@(when (or (member (car body) 
			   '(:always :never :thereis) 
			   :TEST #'eq)
		   quits postquits)
	   '((ABORT nil)))
       ,@(unless (member (car body) 
			 '(:do :max :min :sum :count) 
			 :TEST #'eq) 
	   '((RESULTS nil)))
       ,@(when (member (car body) '(:max :min) :TEST #'eq)
	   '((TEMP nil)(EXTREME nil)))
       ,@(when (member (car body) '(:sum :count) :TEST #'eq)
	   '((COUNTER 0))))
;;;
;;; Now construct the endtest and return form.
;;;
      ((or ,.end-test-forms)
;;;
;;; Finals to be executed before returning.
;;;
       ,@final-forms
;;;
;;; Value to be returned.
;;;
       ,@return-forms)
;;;
;;; Update the IN variables.
;;;
      ,.init-forms
;;;
;;; Check if time to quit.
;;;
      ,.(make-do-quit-form quits)
;;;
;;; Execute the body.
;;;
      ,.(cond (quits
	       `((unless ABORT ,.(make-do-body body filters variables))))
	      (t (make-do-body body filters variables)))
;;;
;;; Check if time to quit (postquits).
;;;
      ,.(make-do-quit-form postquits)
;;;
;;; If ABORT is set, then we want to eval final-forms and return-forms
;;; before DO updates its iteration variables.  
;;;
      ,@(when (or (member (car body) 
			  '(:always :never :thereis) 
			  :TEST #'eq)
		  quits postquits)
	  `((when ABORT
	      ,@final-forms ,@return-forms))))))	   

;;; MAKE-DO-VARIABLE-FORMS is tricky. First, it must return a list of
;;; variable forms for the variable binding part of the do. Second, it
;;; must return a set of initialization forms executed each time thru
;;; the loop in order to handle :IN variables. Finally, it must create
;;; the proper terminations condition tests for these variables. It
;;; returns all three values for incorporation into the do.

(defun make-do-variable-forms (variables)
  (let ((variable-forms nil) 
	(initialization-forms nil) 
	(end-test-forms nil))
    (mapc #'(lambda (record &optional tail-name)
	      (case (cadr record)
		(:in
		 (setq tail-name (gentemp (string (car record))))
		 (push `(,(car record) nil) variable-forms)
		 (push `(,tail-name ,(caddr record) (cdr ,tail-name))
		       variable-forms)
		 (push `(setq ,(car record) (car ,tail-name)) 
		       initialization-forms)
		 (push `(null ,tail-name) end-test-forms))
		(:on
		 (push `(,(car record) ,(caddr record) (cdr ,(car record))) 
		       variable-forms)
		 (push `(null ,(car record)) end-test-forms))
		(:from
		 (push `(,(car record) ,(car (caddr record))
			 (+ ,(car record) ,(caddr (caddr record)))) 
		       variable-forms)
		 (when (cadr (caddr record))
		   (push `(cond ((minusp ,(caddr (caddr record)))
				 (< ,(car record) ,(cadr (caddr record))))
				(t (> ,(car record) ,(cadr (caddr record)))))
			 end-test-forms)))))
	  variables)
    (values (nreverse variable-forms) 
	    (nreverse initialization-forms)
	    (nreverse end-test-forms))))

;;; MAKE-DO-BODY constructs the body of the do expansion. It wraps a
;;; call to make-body with the proper housekeeping chores required to
;;; return the proper result. Note that a collect with filters needs an
;;; extra level of nesting so the return form can be like joins: i.e.,
;;; supplying an extra nconc.

(defun make-do-body (body filters &optional variables)
  (case (car body)
    (:do 
     (make-body body filters))
    (:thereis
     `((when (setq ABORT ,.(make-body body filters :progn-wrap t))
	 (setq RESULTS ,(caar variables)))))
    (:always
     `((unless ,.(make-body body filters :progn-wrap t :flush-form t)
	 (setq ABORT t)
	 (setq RESULTS t))))
    (:never
     `((when ,.(make-body body filters :progn-wrap t)
	 (setq ABORT t)
	 (setq RESULTS t))))
    (:max
     `((when (setq TEMP ,.(make-body body filters :progn-wrap t))
	 (when (or (null EXTREME)(> TEMP EXTREME))
	   (setq EXTREME TEMP)))))
    (:min
     `((when (setq TEMP ,.(make-body body filters :progn-wrap t))
	 (when (or (null EXTREME)(< TEMP EXTREME))
	   (setq EXTREME TEMP)))))
    (:sum
     `((setq COUNTER 
	     (+ COUNTER 
		,.(make-body body filters :progn-wrap t :flush-form 0)))))
    (:count
     `((when ,.(make-body body filters :progn-wrap t)
	 (setq COUNTER (1+ COUNTER)))))
    (:collect
     `((push ,.(make-body body filters :progn-wrap t 
			  :nest-result (when filters t)) RESULTS)))
    (t `((push ,.(make-body body filters :progn-wrap t) RESULTS)))))

;;; MAKE-DO-QUIT-FORM constructs a form to check if the termination
;;; conditions are met. If so, we set the ABORT variable which is
;;; checked as part of the do endtest.

(defun make-do-quit-form (quits)
  (mapcar #'(lambda (clause)
	      (case (car clause)
		((:while :repeatwhile) 
		 `(unless (and ,.(reexpand (cdr clause))) (setq ABORT t)))
		((:until :repeatuntil) 
		 `(when (or ,.(reexpand (cdr clause))) (setq ABORT t)))))
	  quits))

;;; MAKE-DO-RETURN-FORM constructs a form that, when evaluated at the
;;; end of the iteration, returns the proper value, depending on the
;;; type of FOR this is. The filters argument is necessary only when
;;; dealing with a collect, in order to see if an extra nconc is
;;; necessary or not.

(defun make-do-return-form (body filters)
  (case (car body)
    (:do
     '((return nil)))
    (:join
     '((return (nreverse (apply #'nconc RESULTS)))))
    (:collect
     (cond (filters '((return (nreverse (apply #'nconc RESULTS)))))
	   (t '((return (nreverse RESULTS))))))
    (:thereis
     '((return RESULTS)))
    ((:always :never)
     '((return (not RESULTS))))
    ((:max :min)
     '((return EXTREME)))
    ((:sum :count)
     '((return COUNTER)))))
SHAR_EOF
cat << \SHAR_EOF > mexp.lsp
;;;   -*- Syntax: Common-Lisp; Package: USER; Base: 10; Mode: LISP -*-    ;;;
;;;                                                                       ;;;
;;;   Copyright (c) 1988 Cornell Apprentice Project, Cornell University   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide 'mexp)

;;; Macroexpand top-level loop. Expands one-level of macros. If the 
;;; optional argument is given, will expand all levels of macros.

(defun mexp (&optional fullexpand?)
  (prog (expr)
	(format t "~&Macroexpand top-level loop (:q to quit).~%")
	loop 
	(format t "~%~A> " (cond (fullexpand? "mexp*")
				 (t "mexp")))
	(setq expr (read))
	(case expr
	      (:q (return))
	      (t (format t "~S~%" 
			 (cond (fullexpand? (macroexpand expr))
			       (t (macroexpand-1 expr))))
		 (go loop))))
  (format t "~%"))
SHAR_EOF
cat << \SHAR_EOF > for-tran.el
;;;   -*- Syntax: Common-Lisp; Package: USER; Base: 10; Mode: LISP -*-    ;;;
;;;                                                                       ;;;
;;;   Copyright (c) 1988 Cornell Apprentice Project, Cornell University   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Conversion facility in GNU lisp for transforming old-style non
;;; keyword-package for macro keywords to the new-style
;;; keyword-package keywords. Walks you through all of the for macros
;;; and asks you before replacing anything. Careful of when/unless
;;; that may in fact be Lisp forms!

;;; This isn't supposed to be good code, so I don't want to hear about
;;; it. It's cheap, dirty, and you're only going to use it once
;;; anyway.

;;; Bind it to M-C-c

(define-key lisp-mode-map "" 'convert-for-macro)

;;; A for macro starts either with (for or (bind. Filter out any
;;; (format statements, since there are likely to be lots of those.

(defun convert-for-macro ()
  "Convert the for macros in current buffer."
  (interactive)
  (save-excursion
    (let (begin)
      (goto-char (point-min))
      (while (and (not (eobp))
		  (identify-macro-sexpr "(for"))
	(search-backward "(")
	(message (format "Found %s" (buffer-substring (point) (+ (point) 10))))
	(cond ((looking-at "(format")(forward-sexp 1))
	      (t (setq begin (point))
		 (forward-sexp 1)
		 (narrow-to-region begin (point))
		 (goto-char begin)
		 (convert-for-macro-sexpr nil)
		 (goto-char (point-max))
		 (widen))))
      (goto-char (point-min))
      (while (and (not (eobp))
		  (identify-macro-sexpr "(bind"))
	(search-backward "(")
	(setq begin (point))
	(forward-sexp 1)
	(narrow-to-region begin (point))
	(goto-char begin)
	(convert-for-macro-sexpr t)
	(goto-char (point-max))
	(widen)))))

(defun identify-macro-sexpr (string)
  "Identify a for macro sexpr."
    (search-forward string (point-max) t))

;;; Here's the replacements that need to be done.

(defun convert-for-macro-sexpr (bind-form)
  "Converts a single for macro sexpr."
  (or bind-form (progn (query-replace "bind" ":bind" t)
		       (goto-char (point-min))))
  (mapcar '(lambda (cons-pair)
	     (query-replace (car cons-pair)(cdr cons-pair) t)
	     (goto-char (point-min)))
	  '(("in" . ":in") ("on" . ":on") ("from" . ":from") ("by" . ":by") 
	    ("to" . ":to") ("as" . ":as") ("initially" . ":initially") 
	    ("when" . ":when") ("unless" . ":unless") ("while" . ":while") 
	    ("until" . ":until") ("do" . ":do") ("join" . ":join") 
	    ("collect" . ":collect") ("thereis" . ":thereis") 
	    ("always" . ":always") ("never" . ":never") 
	    ("max" . ":max") ("min" . ":min") ("sum" . ":sum") 
	    ("count" . ":count") ("repeatwhile" . ":repeatwhile") 
	    ("repeatuntil" . ":repeatuntil") ("finally" . ":finally"))))
SHAR_EOF
cat << \SHAR_EOF > mv+
#!/bin/csh
#
#   mv+ pattern1 pattern2 file1 [ file2 ...  ]
#
#   rename files by replacing the last pattern1 with pattern2

set noglob

set x = $1	# what it was
shift
set y = $1	# what it shall be
shift

foreach f ( $* )
    if ( `expr match $f '.*'$x'.*'` ) then      
	set a = `expr match $f '\(.*\)'$x'.*'`
	set b = `expr match $f '.*'$x'\(.*\)'`
	echo mv $f $a$y$b
	mv $f $a$y$b
    else
	echo $f not moved.
    endif
end
echo finished.
SHAR_EOF
#	End of shell archive
exit 0