/[gcl]/gcl/lsp/loop.lsp
ViewVC logotype

Diff of /gcl/lsp/loop.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Thu May 16 21:52:46 2002 UTC revision 1.2 by camm, Mon Jun 10 18:36:36 2002 UTC
# Line 1  Line 1 
1  ;;;   -*- Mode:LISP; Syntax:Common-Lisp; Package:LOOP; Base:10; Lowercase:T -*-  ;;;   -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase:T -*-
2  ;;;   *************************************************************************  ;;;>
3  ;;;   ******* Common Lisp ******** LOOP Iteration Macro ***********************  ;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology.
4  ;;;   *************************************************************************  ;;;> All Rights Reserved.
5  ;;;   ***** (C) COPYRIGHT 1980, 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ****  ;;;>
6  ;;;   ********* THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ***************  ;;;> Permission to use, copy, modify and distribute this software and its
7  ;;;   *************************************************************************  ;;;> documentation for any purpose and without fee is hereby granted,
8    ;;;> provided that the M.I.T. copyright notice appear in all copies and that
9    ;;;> both that copyright notice and this permission notice appear in
10    ;;;> supporting documentation.  The names "M.I.T." and "Massachusetts
11    ;;;> Institute of Technology" may not be used in advertising or publicity
12    ;;;> pertaining to distribution of the software without specific, written
13    ;;;> prior permission.  Notice must be given in supporting documentation that
14    ;;;> copying distribution is by permission of M.I.T.  M.I.T. makes no
15    ;;;> representations about the suitability of this software for any purpose.
16    ;;;> It is provided "as is" without express or implied warranty.
17    ;;;>
18    ;;;>      Massachusetts Institute of Technology
19    ;;;>      77 Massachusetts Avenue
20    ;;;>      Cambridge, Massachusetts  02139
21    ;;;>      United States of America
22    ;;;>      +1-617-253-1000
23    ;;;>
24    ;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc.
25    ;;;> All Rights Reserved.
26    ;;;>
27    ;;;> Permission to use, copy, modify and distribute this software and its
28    ;;;> documentation for any purpose and without fee is hereby granted,
29    ;;;> provided that the Symbolics copyright notice appear in all copies and
30    ;;;> that both that copyright notice and this permission notice appear in
31    ;;;> supporting documentation.  The name "Symbolics" may not be used in
32    ;;;> advertising or publicity pertaining to distribution of the software
33    ;;;> without specific, written prior permission.  Notice must be given in
34    ;;;> supporting documentation that copying distribution is by permission of
35    ;;;> Symbolics.  Symbolics makes no representations about the suitability of
36    ;;;> this software for any purpose.  It is provided "as is" without express
37    ;;;> or implied warranty.
38    ;;;>
39    ;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera,
40    ;;;> and Zetalisp are registered trademarks of Symbolics, Inc.
41    ;;;>
42    ;;;>      Symbolics, Inc.
43    ;;;>      8 New England Executive Park, East
44    ;;;>      Burlington, Massachusetts  01803
45    ;;;>      United States of America
46    ;;;>      +1-617-221-1000
47    
48    ;; $aclHeader: loop.cl,v 1.5 91/12/04 01:13:48 cox acl4_1 $
49    
50    #+cmu
51    (ext:file-comment
52     "$Header$")
53    
54  ;;;; LOOP Iteration Macro  ;;;; LOOP Iteration Macro
55    
56  ;;; This is the "officially sanctioned" version of LOOP for running in  #+allegro
57  ;;; Common Lisp.  It is a conversion of LOOP 829, which is fairly close to  (in-package :excl)
58  ;;; that released with Symbolics Release 6.1 (803).  This conversion was  #+ecls
59  ;;; made by Glenn Burke (one of the original author/maintainers);  the  (in-package "SI")
60  ;;; work was performed at Palladian Software, in Cambridge MA, April 1986.  
61  ;;;  #-(or allegro ecls)
62  ;;; The current version of this file will be maintained at MIT, available  (in-package :ansi-loop)
63  ;;; for anonymous FTP on MC.LCS.MIT.EDU from the file "LSB1;CLLOOP >".  This  
64  ;;; location will no doubt change sometime in the future.  #-ecls
65  ;;;  (provide :loop)
66    
67    #+Cloe-Runtime                                  ;Don't ask.
68    (car (push "%Z% %M% %I% %E% %U%" system::*module-identifications*))
69    
70    ;;; Technology.
71    ;;;
72    ;;; The LOOP iteration macro is one of a number of pieces of code
73    ;;; originally developed at MIT for which free distribution has been
74    ;;; permitted, as long as the code is not sold for profit, and as long
75    ;;; as notification of MIT's interest in the code is preserved.
76    ;;;
77    ;;; This version of LOOP, which is almost entirely rewritten both as
78    ;;; clean-up and to conform with the ANSI Lisp LOOP standard, started
79    ;;; life as MIT LOOP version 829 (which was a part of NIL, possibly
80    ;;; never released).
81    ;;;
82    ;;; A "light revision" was performed by me (Glenn Burke) while at
83    ;;; Palladian Software in April 1986, to make the code run in Common
84    ;;; Lisp.  This revision was informally distributed to a number of
85    ;;; people, and was sort of the "MIT" version of LOOP for running in
86    ;;; Common Lisp.
87  ;;;  ;;;
88  ;;; This file was actually taken from trix.ai.mit.edu.  ;;; A later more drastic revision was performed at Palladian perhaps a
89    ;;; year later.  This version was more thoroughly Common Lisp in style,
90    ;;; with a few miscellaneous internal improvements and extensions.  I
91    ;;; have lost track of this source, apparently never having moved it to
92    ;;; the MIT distribution point.  I do not remember if it was ever
93    ;;; distributed.
94  ;;;  ;;;
95  ;;; This file, like the LOOP it is derived from, has unrestricted  ;;; This revision for the ANSI standard is based on the code of my April
96  ;;; distribution -- anyone may take it and use it.  But for the sake of  ;;; 1986 version, with almost everything redesigned and/or rewritten.
97  ;;; consistency, bug reporting, compatibility, and users' sanity, PLEASE  
98  ;;; PLEASE PLEASE don't go overboard with fixes or changes.  Remember that  
99  ;;; this version is supposed to be compatible with the Maclisp/Zetalisp/NIL  ;;; The design of this LOOP is intended to permit, using mostly the same
100  ;;; LOOP;  it is NOT intended to be "different" or "better" or "redesigned".  ;;; kernel of code, up to three different "loop" macros:
 ;;; Report bugs and propose fixes to BUG-LOOP@MC.LCS.MIT.EDU;  
 ;;; announcements about LOOP will be made to the mailing list  
 ;;; INFO-LOOP@MC.LCS.MIT.EDU.  Mail concerning those lists (such as requests  
 ;;; to be added) should be sent to the BUG-LOOP-REQUEST and  
 ;;; INFO-LOOP-REQUEST lists respectively.  Note the Change History page  
 ;;; below...  
101  ;;;  ;;;
102  ;;; LOOP documentation is still probably available from the MIT Laboratory  ;;; (1) The unextended, unextensible ANSI standard LOOP;
103  ;;; for Computer Science publications office:  ;;;
104  ;;;     LCS Publications  ;;; (2) A clean "superset" extension of the ANSI LOOP which provides
105  ;;;     545 Technology Square  ;;; functionality similar to that of the old LOOP, but "in the style of"
106  ;;;     Cambridge, MA 02139  ;;; the ANSI LOOP.  For instance, user-definable iteration paths, with a
107  ;;; It is Technical Memo 169, "LOOP Iteration Macro", and is very old.  The  ;;; somewhat cleaned-up interface.
108  ;;; most up-to-date documentation on this version of LOOP is that in the NIL  ;;;
109  ;;; Reference Manual (TR-311 from LCS Publications);  while you wouldn't  ;;; (3) Extensions provided in another file which can make this LOOP
110  ;;; want to get that (it costs nearly $15) just for LOOP documentation,  ;;; kernel behave largely compatibly with the Genera-vintage LOOP macro,
111  ;;; those with access to a NIL manual might photocopy the chapter on LOOP.  ;;; with only a small addition of code (instead of two whole, separate,
112  ;;; That revised documentation can be reissued as a revised technical memo  ;;; LOOP macros).
 ;;; if there is sufficient demand.  
113  ;;;  ;;;
114    ;;; Each of the above three LOOP variations can coexist in the same LISP
115    ;;; environment.
116    ;;;
117    
118    
119  ;;;; Change History  ;;;; Miscellaneous Environment Things
120    
 ;;; [gsb@palladian] 30-apr-86 00:26  File Created from NIL's LOOP version 829  
 ;;; [gsb@palladian] 30-oct-86 18:23  don't generate (type notype var) decls, special-case notype into T.  
 ;;;                 (The NOTYPE type keyword needs to be around for compatibility.)  
 ;;; [gsb@palladian] 30-oct-86 18:48  bogus case clause in loop-do-collect.  Syntax:common-lisp in file  
 ;;;                 attribute list, for symbolics gratuitousness.  
 ;;; [jeff@palladian] 22-jul-87 19:44 Export loop-simple-error.  
 ;;;------------------------------------------------------------------------  
 ;;;------- End of official change history -- note local fixes below -------  
 ;;;------------------------------------------------------------------------  
121    
 ;;; [boyer@cs.utexas.edu] 9-july-87  In define-loop-macro moved  
 ;;; &environment and its formal to right after &whole to overcome a bug  
 ;;; in KCL.  
122    
123    ;;;The LOOP-Prefer-POP feature makes LOOP generate code which "prefers" to use POP or
124    ;;; its obvious expansion (prog1 (car x) (setq x (cdr x))).  Usually this involves
125    ;;; shifting fenceposts in an iteration or series of carcdr operations.  This is
126    ;;; primarily recognized in the list iterators (FOR .. {IN,ON}), and LOOP's
127    ;;; destructuring setq code.
128    (eval-when (compile load eval)
129      #+(or Genera Minima) (pushnew :LOOP-Prefer-POP *features*)
130      )
131    
132    
133    ;;; The uses of this macro are retained in the CL version of loop, in
134    ;;; case they are needed in a particular implementation.  Originally
135    ;;; dating from the use of the Zetalisp COPYLIST* function, this is used
136    ;;; in situations where, were cdr-coding in use, having cdr-NIL at the
137    ;;; end of the list might be suboptimal because the end of the list will
138    ;;; probably be RPLACDed and so cdr-normal should be used instead.
139    (defmacro loop-copylist* (l)
140      #+Genera `(lisp:copy-list ,l nil t)           ; arglist = (list &optional area force-dotted)
141      ;;Explorer??
142      #-Genera `(copy-list ,l)
143      )
144    
145    
146    (defvar *loop-gentemp*
147            nil)
148    
149    (defun loop-gentemp (&optional (pref 'loopvar-))
150      (if *loop-gentemp*
151          (gentemp (string pref))
152          (gensym)))
153    
154    
155    
156    (defvar *loop-real-data-type* 'real)
157    
158    
159    (defun loop-optimization-quantities (env)
160      ;; The ANSI conditionalization here is for those lisps that implement
161      ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS).
162      ;; It is really commentary on how this code could be written.  I don't
163      ;; actually expect there to be an ANSI #+-conditional -- it should be
164      ;; replaced with the appropriate conditional name for your
165      ;; implementation/dialect.
166      (declare #-ANSI (ignore env)
167               #+Genera (values speed space safety compilation-speed debug))
168      #+ANSI (let ((stuff (declaration-information 'optimize env)))
169               (values (or (cdr (assoc 'speed stuff)) 1)
170                       (or (cdr (assoc 'space stuff)) 1)
171                       (or (cdr (assoc 'safety stuff)) 1)
172                       (or (cdr (assoc 'compilation-speed stuff)) 1)
173                       (or (cdr (assoc 'debug stuff)) 1)))
174      #+CLOE-Runtime (values compiler::time compiler::space
175                             compiler::safety compiler::compilation-speed 1)
176      #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1))
177    
178    
179    ;;; The following form takes a list of variables and a form which presumably
180    ;;; references those variables, and wraps it somehow so that the compiler does not
181    ;;; consider those variables have been referenced.  The intent of this is that
182    ;;; iteration variables can be flagged as unused by the compiler, e.g. I in
183    ;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage
184    ;;; of it is "invisible" or "not to be considered".
185    ;;;We implicitly assume that a setq does not count as a reference.  That is, the
186    ;;; kind of form generated for the above loop construct to step I, simplified, is
187    ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))).
188    (defun hide-variable-references (variable-list form)
189      (declare #-Genera (ignore variable-list))
190      #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form)
191      #-Genera form)
192    
193    
194    ;;; The following function takes a flag, a variable, and a form which presumably
195    ;;; references that variable, and wraps it somehow so that the compiler does not
196    ;;; consider that variable to have been referenced.  The intent of this is that
197    ;;; iteration variables can be flagged as unused by the compiler, e.g. I in
198    ;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage
199    ;;; of it is "invisible" or "not to be considered".
200    ;;;We implicitly assume that a setq does not count as a reference.  That is, the
201    ;;; kind of form generated for the above loop construct to step I, simplified, is
202    ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))).
203    ;;;Certain cases require that the "invisibility" of the reference be conditional upon
204    ;;; something.  This occurs in cases of "named" variables (the USING clause).  For instance,
205    ;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...)
206    ;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is
207    ;;; not referenced.  However, if no USING clause is present, we definitely do not
208    ;;; want to be informed that some random gensym is not used.
209    ;;;It is easier for the caller to do this conditionally by passing a flag (which
210    ;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than
211    ;;; for all callers to contain the conditional invisibility construction.
212    (defun hide-variable-reference (really-hide variable form)
213      (declare #-Genera (ignore really-hide variable))
214      #+Genera (if (and really-hide variable (atom variable))       ;Punt on destructuring patterns
215                   `(compiler:invisible-references (,variable) ,form)
216                   form)
217      #-Genera form)
218    
219    
220    ;;;; List Collection Macrology
221    
222    
223    (defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var)
224                                              &body body)
225      ;; TI? Exploder?
226      #+LISPM (let ((head-place (or user-head-var head-var)))
227                `(let* ((,head-place nil)
228                        (,tail-var
229                          ,(hide-variable-reference
230                             user-head-var user-head-var
231                             `(progn #+Genera (scl:locf ,head-place)
232                                     #-Genera (system:variable-location ,head-place)))))
233                   ,@body))
234      #-LISPM (let ((l (and user-head-var (list (list user-head-var nil)))))
235                #+CLOE `(sys::with-stack-list* (,head-var nil nil)
236                          (let ((,tail-var ,head-var) ,@l)
237                            ,@body))
238                #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
239                          ,@body)))
240    
241    
242    (defmacro loop-collect-rplacd (&environment env
243                                   (head-var tail-var &optional user-head-var) form)
244      (declare
245        #+LISPM (ignore head-var user-head-var)     ;use locatives, unconditionally update through the tail.
246        )
247      (setq form (macroexpand form env))
248      (flet ((cdr-wrap (form n)
249               (declare (fixnum n))
250               (do () ((<= n 4) (setq form `(,(case n
251                                                (1 'cdr)
252                                                (2 'cddr)
253                                                (3 'cdddr)
254                                                (4 'cddddr))
255                                             ,form)))
256                 (setq form `(cddddr ,form) n (- n 4)))))
257        (let ((tail-form form) (ncdrs nil))
258          ;;Determine if the form being constructed is a list of known length.
259          (when (consp form)
260            (cond ((eq (car form) 'list)
261                   (setq ncdrs (1- (length (cdr form))))
262                   ;; Because the last element is going to be RPLACDed,
263                   ;; we don't want the cdr-coded implementations to use
264                   ;; cdr-nil at the end (which would just force copying
265                   ;; the whole list again).
266                   #+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
267                  ((member (car form) '(list* cons))
268                   (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
269                     (setq ncdrs (- (length (cdr form)) 2))))))
270          (let ((answer
271                  (cond ((null ncdrs)
272                         `(when (setf (cdr ,tail-var) ,tail-form)
273                            (setq ,tail-var (last (cdr ,tail-var)))))
274                        ((< ncdrs 0) (return-from loop-collect-rplacd nil))
275                        ((= ncdrs 0)
276                         ;; Here we have a choice of two idioms:
277                         ;; (rplacd tail (setq tail tail-form))
278                         ;; (setq tail (setf (cdr tail) tail-form)).
279                         ;;Genera and most others I have seen do better with the former.
280                         `(rplacd ,tail-var (setq ,tail-var ,tail-form)))
281                        (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
282                                                       ncdrs))))))
283            ;;If not using locatives or something similar to update the user's
284            ;; head variable, we've got to set it...  It's harmless to repeatedly set it
285            ;; unconditionally, and probably faster than checking.
286            #-LISPM (when user-head-var
287                      (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
288            answer))))
289    
290    
291    (defmacro loop-collect-answer (head-var &optional user-head-var)
292      (or user-head-var
293          (progn
294            ;;If we use locatives to get tail-updating to update the head var,
295            ;; then the head var itself contains the answer.  Otherwise we
296            ;; have to cdr it.
297            #+LISPM head-var
298            #-LISPM `(cdr ,head-var))))
299    
300    
301    ;;;; Maximization Technology
302    
303    
304    #|
305    The basic idea of all this minimax randomness here is that we have to
306    have constructed all uses of maximize and minimize to a particular
307    "destination" before we can decide how to code them.  The goal is to not
308    have to have any kinds of flags, by knowing both that (1) the type is
309    something which we can provide an initial minimum or maximum value for
310    and (2) know that a MAXIMIZE and MINIMIZE are not being combined.
311    
312    SO, we have a datastructure which we annotate with all sorts of things,
313    incrementally updating it as we generate loop body code, and then use
314    a wrapper and internal macros to do the coding when the loop has been
315    constructed.
316    |#
317    
318    
319    (defstruct (loop-minimax
320                 #+ecls (:type vector)
321                 (:constructor make-loop-minimax-internal)
322                 #+nil (:copier nil)
323                 #+nil (:predicate nil))
324      answer-variable
325      type
326      temp-variable
327      flag-variable
328      operations
329      infinity-data)
330    
331    
332    (defvar *loop-minimax-type-infinities-alist*
333            ;; This is the sort of value this should take on for a Lisp that has
334            ;; "eminently usable" infinities.  n.b. there are neither constants nor
335            ;; printed representations for infinities defined by CL.
336            ;; This grotesque read-from-string below is to help implementations
337            ;; which croak on the infinity character when it appears in a token, even
338            ;; conditionalized out.
339    ;       #+Genera
340    ;         '#.(read-from-string
341    ;             "((fixnum         most-positive-fixnum     most-negative-fixnum)
342    ;               (short-float    +1s                     -1s)
343    ;               (single-float   +1f                     -1f)
344    ;               (double-float   +1d                     -1d)
345    ;               (long-float     +1l                     -1l))")
346            ;;This is how the alist should look for a lisp that has no infinities.  In
347            ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive.
348            #+(or CLOE-Runtime Minima)
349              '((fixnum             most-positive-fixnum            most-negative-fixnum)
350                (short-float        most-positive-short-float       most-negative-short-float)
351                (single-float       most-positive-single-float      most-negative-single-float)
352                (double-float       most-positive-double-float      most-negative-double-float)
353                (long-float         most-positive-long-float        most-negative-long-float))
354            ;; CMUCL has infinities so let's use them.
355            #+CMU
356              '((fixnum             most-positive-fixnum                    most-negative-fixnum)
357                (short-float        ext:single-float-positive-infinity      ext:single-float-negative-infinity)
358                (single-float       ext:single-float-positive-infinity      ext:single-float-negative-infinity)
359                (double-float       ext:double-float-positive-infinity      ext:double-float-negative-infinity)
360                (long-float         ext:long-float-positive-infinity        ext:long-float-negative-infinity))
361            ;; If we don't know, then we cannot provide "infinite" initial values for any of the
362            ;; types but FIXNUM:
363            #-(or Genera CLOE-Runtime Minima CMU)
364              '((fixnum             most-positive-fixnum            most-negative-fixnum))
365              )
366    
367    
368    (defun make-loop-minimax (answer-variable type)
369      (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep))))
370        (make-loop-minimax-internal
371          :answer-variable answer-variable
372          :type type
373          :temp-variable (loop-gentemp 'loop-maxmin-temp-)
374          :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-))
375          :operations nil
376          :infinity-data infinity-data)))
377    
378    
379    (defun loop-note-minimax-operation (operation minimax)
380      (pushnew (the symbol operation) (loop-minimax-operations minimax))
381      (when (and (cdr (loop-minimax-operations minimax))
382                 (not (loop-minimax-flag-variable minimax)))
383        (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-)))
384      operation)
385    
386    
387    (defmacro with-minimax-value (lm &body body)
388      (let ((init (loop-typed-init (loop-minimax-type lm)))
389            (which (car (loop-minimax-operations lm)))
390            (infinity-data (loop-minimax-infinity-data lm))
391            (answer-var (loop-minimax-answer-variable lm))
392            (temp-var (loop-minimax-temp-variable lm))
393            (flag-var (loop-minimax-flag-variable lm))
394            (type (loop-minimax-type lm)))
395        (if flag-var
396            `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil))
397               (declare (type ,type ,answer-var ,temp-var))
398               ,@body)
399            `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data)))
400                   (,temp-var ,init))
401               (declare (type ,type ,answer-var ,temp-var))
402               ,@body))))
403    
404    
405    (defmacro loop-accumulate-minimax-value (lm operation form)
406      (let* ((answer-var (loop-minimax-answer-variable lm))
407             (temp-var (loop-minimax-temp-variable lm))
408             (flag-var (loop-minimax-flag-variable lm))
409             (test
410               (hide-variable-reference
411                 t (loop-minimax-answer-variable lm)
412                 `(,(ecase operation
413                      (min '<)
414                      (max '>))
415                   ,temp-var ,answer-var))))
416        `(progn
417           (setq ,temp-var ,form)
418           (when ,(if flag-var `(or (not ,flag-var) ,test) test)
419             (setq ,@(and flag-var `(,flag-var t))
420                   ,answer-var ,temp-var)))))
421    
422    
423    
424    ;;;; Loop Keyword Tables
425    
426    
427    #|
428    LOOP keyword tables are hash tables string keys and a test of EQUAL.
429    
430    The actual descriptive/dispatch structure used by LOOP is called a "loop
431    universe" contains a few tables and parameterizations.  The basic idea is
432    that we can provide a non-extensible ANSI-compatible loop environment,
433    an extensible ANSI-superset loop environment, and (for such environments
434    as CLOE) one which is "sufficiently close" to the old Genera-vintage
435    LOOP for use by old user programs without requiring all of the old LOOP
436    code to be loaded.
437    |#
438    
 ;;;; Package setup  
439    
440  ;(provide 'loop)  ;;;; Token Hackery
441    
442    
443  ;;;The following symbols are documented as being available via SI:.  Far be  ;;;Compare two "tokens".  The first is the frob out of *LOOP-SOURCE-CODE*,
444  ;;;it for us to define a package by that name, however we can do the  ;;; the second a symbol to check against.
445  ;;;following.  We will create a "loop-si-kludge" package (sounds like a  (defun loop-tequal (x1 x2)
446  ;;;fairly safe name), import the SI: symbols from there into LOOP, export    (and (symbolp x1) (string= x1 x2)))
 ;;;them, define that people (use-package 'loop), and if they want to  
 ;;;maintain source compatibility they can add the SI nickname the  
 ;;;loop-si-kludge package.  How's that?  
447    
 ;(in-package 'loop-si-kludge)  
448    
449  ;(export '(loop-tequal loop-tassoc loop-tmember *loop-use-system-destructuring?*  (defun loop-tassoc (kwd alist)
450  ;         loop-named-variable loop-simplep loop-simplep-1    (and (symbolp kwd) (assoc kwd alist :test #'string=)))
 ;         loop-sequencer loop-sequence-elements-path))  
451    
 (in-package "SYSTEM")  
452    
453  ;(use-package '(loop-si-kludge))  (defun loop-tmember (kwd list)
454      (and (symbolp kwd) (member kwd list :test #'string=)))
455    
 ;shadow?  
456    
457  (export '(loop loop-finish define-loop-macro define-loop-path  (defun loop-lookup-keyword (loop-token table)
458                 define-loop-sequence-path))    (and (symbolp loop-token)
459           (values (gethash (symbol-name loop-token) table))))
460    
461    
462    (defmacro loop-store-table-data (symbol table datum)
463      `(setf (gethash (symbol-name ,symbol) ,table) ,datum))
464    
465    
466    (defstruct (loop-universe
467                 #+ecls (:type vector)
468                 #-ecls (:print-function print-loop-universe)
469                 #+nil (:copier nil)
470                 #+nil (:predicate nil))
471      keywords                                      ;hash table, value = (fn-name . extra-data).
472      iteration-keywords                            ;hash table, value = (fn-name . extra-data).
473      for-keywords                                  ;hash table, value = (fn-name . extra-data).
474      path-keywords                                 ;hash table, value = (fn-name . extra-data).
475      type-symbols                                  ;hash table of type SYMBOLS, test EQ, value = CL type specifier.
476      type-keywords                                 ;hash table of type STRINGS, test EQUAL, value = CL type spec.
477      ansi                                          ;NIL, T, or :EXTENDED.
478      implicit-for-required                         ;see loop-hack-iteration
479      )
480    
481    
482    #-ecls
483    (defun print-loop-universe (u stream level)
484      (declare (ignore level))
485      (let ((str (case (loop-universe-ansi u)
486                   ((nil) "Non-ANSI")
487                   ((t) "ANSI")
488                   (:extended "Extended-ANSI")
489                   (t (loop-universe-ansi u)))))
490        ;;Cloe could be done with the above except for bootstrap lossage...
491        #+CLOE
492        (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u))
493        #+Genera                                    ; This is reallly the ANSI definition.
494        (print-unreadable-object (u stream :type t :identity t)
495          (princ str stream))
496        #-(or Genera CLOE)
497        (format stream "#<~S ~A>" (type-of u) str)
498        ))
499    
500    
501    ;;;This is the "current" loop context in use when we are expanding a
502    ;;;loop.  It gets bound on each invocation of LOOP.
503    (defvar *loop-universe*)
504    
505    
506    (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords
507                                        type-keywords type-symbols ansi)
508      #-(and CLOE Source-Bootstrap ecls) (check-type ansi (member nil t :extended))
509      (flet ((maketable (entries)
510               (let* ((size (length entries))
511                      (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal)))
512                 (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x)))
513                 ht)))
514        (make-loop-universe
515          :keywords (maketable keywords)
516          :for-keywords (maketable for-keywords)
517          :iteration-keywords (maketable iteration-keywords)
518          :path-keywords (maketable path-keywords)
519          :ansi ansi
520          :implicit-for-required (not (null ansi))
521          :type-keywords (maketable type-keywords)
522          :type-symbols (let* ((size (length type-symbols))
523                               (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq)))
524                          (dolist (x type-symbols)
525                            (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x))))
526                          ht))))
527    
528    
529  (export '(loop-tequal loop-tassoc loop-tmember *loop-use-system-destructuring?*  ;;;; Setq Hackery
           loop-named-variable loop-simple-error loop-simplep loop-simplep-1  
           loop-sequencer loop-sequence-elements-path))  
530    
 ;require?  
531    
532    (defvar *loop-destructuring-hooks*
533  ;;;; Macro Environment Setup          nil
534      "If not NIL, this must be a list of two things:
535    a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.")
536    
537    
538  ;;; The uses of this macro are retained in the CL version of loop, in case they are  (defun loop-make-psetq (frobs)
539  ;;; needed in a particular implementation.  Originally dating from the use of the    (and frobs
540  ;;; Zetalisp COPYLIST* function, this is used in situations where, were cdr-coding         (loop-make-desetq
541  ;;; in use, having cdr-NIL at the end of the list might be suboptimal because the           (list (car frobs)
542  ;;; end of the list will probably be RPLACDed and so cdr-normal should be used instead.                 (if (null (cddr frobs)) (cadr frobs)
543  (defmacro loop-copylist* (l)                     `(prog1 ,(cadr frobs)
544    `(copy-list ,l))                             ,(loop-make-psetq (cddr frobs))))))))
545    
546    
547    (defun loop-make-desetq (var-val-pairs)
548      (if (null var-val-pairs)
549          nil
550          (cons (if *loop-destructuring-hooks*
551                    (cadr *loop-destructuring-hooks*)
552                    'loop-really-desetq)
553                var-val-pairs)))
554    
555    
556    (defvar *loop-desetq-temporary*
557            (make-symbol "LOOP-DESETQ-TEMP"))
558    
559    
560    (defmacro loop-really-desetq (&environment env &rest var-val-pairs)
561      (labels ((find-non-null (var)
562                 ;; see if there's any non-null thing here
563                 ;; recurse if the list element is itself a list
564                 (do ((tail var)) ((not (consp tail)) tail)
565                   (when (find-non-null (pop tail)) (return t))))
566               (loop-desetq-internal (var val &optional temp)
567                 ;; returns a list of actions to be performed
568                 (typecase var
569                   (null
570                     (when (consp val)
571                       ;; don't lose possible side-effects
572                       (if (eq (car val) 'prog1)
573                           ;; these can come from psetq or desetq below.
574                           ;; throw away the value, keep the side-effects.
575                           ;;Special case is for handling an expanded POP.
576                           (mapcan #'(lambda (x)
577                                       (and (consp x)
578                                            (or (not (eq (car x) 'car))
579                                                (not (symbolp (cadr x)))
580                                                (not (symbolp (setq x (macroexpand x env)))))
581                                            (cons x nil)))
582                                   (cdr val))
583                           `(,val))))
584                   (cons
585                     (let* ((car (car var))
586                            (cdr (cdr var))
587                            (car-non-null (find-non-null car))
588                            (cdr-non-null (find-non-null cdr)))
589                       (when (or car-non-null cdr-non-null)
590                         (if cdr-non-null
591                             (let* ((temp-p temp)
592                                    (temp (or temp *loop-desetq-temporary*))
593                                    (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal
594                                                                  car
595                                                                  `(prog1 (car ,temp)
596                                                                          (setq ,temp (cdr ,temp))))
597                                                              ,@(loop-desetq-internal cdr temp temp))
598                                          #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp))
599                                                              (setq ,temp (cdr ,temp))
600                                                              ,@(loop-desetq-internal cdr temp temp))))
601                               (if temp-p
602                                   `(,@(unless (eq temp val)
603                                         `((setq ,temp ,val)))
604                                     ,@body)
605                                   `((let ((,temp ,val))
606                                       ,@body))))
607                             ;; no cdring to do
608                             (loop-desetq-internal car `(car ,val) temp)))))
609                   (otherwise
610                     (unless (eq var val)
611                       `((setq ,var ,val)))))))
612        (do ((actions))
613            ((null var-val-pairs)
614             (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions))))
615          (setq actions (revappend
616                          (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs))
617                          actions)))))
618    
619    
620  ;;;; Random Macros  ;;;; LOOP-local variables
621    
622    ;;;This is the "current" pointer into the LOOP source code.
623    (defvar *loop-source-code*)
624    
 (defmacro loop-simple-error (unquoted-message &optional (datum nil datump))  
   `(error ,(if datump "LOOP:  ~S ~A" "LOOP:  ~A")  
           ',unquoted-message ,@(and datump (list datum))))  
625    
626    ;;;This is the pointer to the original, for things like NAMED that
627    ;;;insist on being in a particular position
628    (defvar *loop-original-source-code*)
629    
 (defmacro loop-warn (unquoted-message &optional (datum nil datump))  
   (if datump  
       `(warn ,(concatenate 'string "LOOP: " unquoted-message " -- ~{~S~^ ~}")  
              ,datum)  
       `(warn ',(concatenate 'string "LOOP: " unquoted-message))))  
630    
631    ;;;This is *loop-source-code* as of the "last" clause.  It is used
632    ;;;primarily for generating error messages (see loop-error, loop-warn).
633    (defvar *loop-source-context*)
634    
 (defmacro loop-pop-source () '(pop *loop-source-code*))  
635    
636  (defmacro loop-gentemp (&optional (pref ''loopvar-))  ;;;List of names for the LOOP, supplied by the NAMED clause.
637    `(gentemp ',(symbol-name (second pref))))  (defvar *loop-names*)
   
638    
639  ;;;; Setq Hackery  ;;;The macroexpansion environment given to the macro.
640    (defvar *loop-macro-environment*)
641    
642  ; Note:  LOOP-MAKE-PSETQ is NOT flushable depending on the existence  ;;;This holds variable names specified with the USING clause.
643  ; of PSETQ, unless PSETQ handles destructuring.  Even then it is  ;;; See LOOP-NAMED-VARIABLE.
644  ; preferable for the code LOOP produces to not contain intermediate  (defvar *loop-named-variables*)
645  ; macros, especially in the PDP10 version.  
646    ;;; LETlist-like list being accumulated for one group of parallel bindings.
647    (defvar *loop-variables*)
648    
649    ;;;List of declarations being accumulated in parallel with
650    ;;;*loop-variables*.
651    (defvar *loop-declarations*)
652    
653    ;;;Used by LOOP for destructuring binding, if it is doing that itself.
654    ;;; See loop-make-variable.
655    (defvar *loop-desetq-crocks*)
656    
657    ;;; List of wrapping forms, innermost first, which go immediately inside
658    ;;; the current set of parallel bindings being accumulated in
659    ;;; *loop-variables*.  The wrappers are appended onto a body.  E.g.,
660    ;;; this list could conceivably has as its value ((with-open-file (g0001
661    ;;; g0002 ...))), with g0002 being one of the bindings in
662    ;;; *loop-variables* (this is why the wrappers go inside of the variable
663    ;;; bindings).
664    (defvar *loop-wrappers*)
665    
666    ;;;This accumulates lists of previous values of *loop-variables* and the
667    ;;;other lists  above, for each new nesting of bindings.  See
668    ;;;loop-bind-block.
669    (defvar *loop-bind-stack*)
670    
671    ;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause
672    ;;;which inhibits  LOOP from actually outputting a type declaration for
673    ;;;an iteration (or any) variable.
674    (defvar *loop-nodeclare*)
675    
676    ;;;This is simply a list of LOOP iteration variables, used for checking
677    ;;;for duplications.
678    (defvar *loop-iteration-variables*)
679    
680    
681    ;;;List of prologue forms of the loop, accumulated in reverse order.
682    (defvar *loop-prologue*)
683    
 (defun loop-make-psetq (frobs)  
     (and frobs  
          (loop-make-setq  
             (list (car frobs)  
                   (if (null (cddr frobs)) (cadr frobs)  
                       `(prog1 ,(cadr frobs)  
                               ,(loop-make-psetq (cddr frobs))))))))  
   
   
 (defvar *loop-use-system-destructuring?*  
     nil)  
   
 (defvar *loop-desetq-temporary*)  
   
 ; Do we want this???  It is, admittedly, useful...  
 ;(defmacro loop-desetq (&rest x)  
 ;  (let ((*loop-desetq-temporary* nil))  
 ;     (let ((setq-form (loop-make-desetq x)))  
 ;       (if *loop-desetq-temporary*  
 ;           `((lambda (,*loop-desetq-temporary*) ,setq-form) nil)  
 ;           setq-form))))  
   
   
 (defun loop-make-desetq (x)  
    (if *loop-use-system-destructuring?*  
        (cons (do ((l x (cddr l))) ((null l) 'setq)  
                (or (and (not (null (car l))) (symbolp (car l)))  
                    (return 'desetq)))  
              x)  
        (do ((x x (cddr x)) (r nil) (var) (val))  
            ((null x) (and r (cons 'setq r)))  
          (setq var (car x) val (cadr x))  
          (cond ((and (not (atom var))  
                      (not (atom val))  
                      (not (and (member (car val) '(car cdr cadr cddr caar cdar))  
                                (atom (cadr val)))))  
                   (setq x (list* (or *loop-desetq-temporary*  
                                      (setq *loop-desetq-temporary*  
                                            (loop-gentemp 'loop-desetq-)))  
                                  val var *loop-desetq-temporary* (cddr x)))))  
          (setq r (nconc r (loop-desetq-internal (car x) (cadr x)))))))  
   
   
 (defun loop-desetq-internal (var val)  
   (cond ((null var) nil)  
         ((atom var) (list var val))  
         (t (nconc (loop-desetq-internal (car var) `(car ,val))  
                   (loop-desetq-internal (cdr var) `(cdr ,val))))))  
   
   
 (defun loop-make-setq (pairs)  
     (and pairs (loop-make-desetq pairs)))  
   
   
 (defconstant +loop-keyword-alist+                       ;clause introducers  
      '( (named loop-do-named)  
         (initially loop-do-initially)  
         (finally loop-do-finally)  
         (nodeclare loop-nodeclare)  
         (do loop-do-do)  
         (doing loop-do-do)  
         (return loop-do-return)  
         (collect loop-do-collect list)  
         (collecting loop-do-collect list)  
         (append loop-do-collect append)  
         (appending loop-do-collect append)  
         (nconc loop-do-collect nconc)  
         (nconcing loop-do-collect nconc)  
         (count loop-do-collect count)  
         (counting loop-do-collect count)  
         (sum loop-do-collect sum)  
         (summing loop-do-collect sum)  
         (maximize loop-do-collect max)  
         (minimize loop-do-collect min)  
         (always loop-do-always nil) ;Normal, do always  
         (never loop-do-always t)    ; Negate the test on always.  
         (thereis loop-do-thereis)  
         (while loop-do-while nil while)     ; Normal, do while  
         (until loop-do-while t until)       ; Negate the test on while  
         (when loop-do-when nil when)        ; Normal, do when  
         (if loop-do-when nil if)    ; synonymous  
         (unless loop-do-when t unless)      ; Negate the test on when  
         (with loop-do-with)))  
   
   
 (defconstant +loop-iteration-keyword-alist+  
     `((for loop-do-for)  
       (as loop-do-for)  
       (repeat loop-do-repeat)))  
   
   
 (defconstant +loop-for-keyword-alist+                   ;Types of FOR  
      '( (= loop-for-equals)  
         (first loop-for-first)  
         (in loop-list-stepper car)  
         (on loop-list-stepper nil)  
         (from loop-for-arithmetic from)  
         (downfrom loop-for-arithmetic downfrom)  
         (upfrom loop-for-arithmetic upfrom)  
         (below loop-for-arithmetic below)  
         (to loop-for-arithmetic to)  
         (being loop-for-being)))  
   
 (defvar *loop-prog-names*)  
   
   
 (defvar *loop-macro-environment*)       ;Second arg to macro functions,  
                                         ;passed to macroexpand.  
   
 (defvar *loop-path-keyword-alist* nil)  ; PATH functions  
 (defvar *loop-named-variables*)         ; see LOOP-NAMED-VARIABLE  
 (defvar *loop-variables*)               ; Variables local to the loop  
 (defvar *loop-declarations*)            ; Local dcls for above  
 (defvar *loop-nodeclare*)               ; but don't declare these  
 (defvar *loop-variable-stack*)  
 (defvar *loop-declaration-stack*)  
 (defvar *loop-desetq-crocks*)           ; see loop-make-variable  
 (defvar *loop-desetq-stack*)            ; and loop-translate-1  
 (defvar *loop-prologue*)                ;List of forms in reverse order  
 (defvar *loop-wrappers*)                ;List of wrapping forms, innermost first  
684  (defvar *loop-before-loop*)  (defvar *loop-before-loop*)
685  (defvar *loop-body*)                    ;..  (defvar *loop-body*)
686  (defvar *loop-after-body*)              ;.. for FOR steppers  (defvar *loop-after-body*)
 (defvar *loop-epilogue*)                ;..  
 (defvar *loop-after-epilogue*)          ;So COLLECT's RETURN comes after FINALLY  
 (defvar *loop-conditionals*)            ;If non-NIL, condition for next form in body  
   ;The above is actually a list of entries of the form  
   ;(cond (condition forms...))  
   ;When it is output, each successive condition will get  
   ;nested inside the previous one, but it is not built up  
   ;that way because you wouldn't be able to tell a WHEN-generated  
   ;COND from a user-generated COND.  
   ;When ELSE is used, each cond can get a second clause  
   
 (defvar *loop-when-it-variable*)        ;See LOOP-DO-WHEN  
 (defvar *loop-never-stepped-variable*)  ; see LOOP-FOR-FIRST  
 (defvar *loop-emitted-body?*)           ; see LOOP-EMIT-BODY,  
                                         ; and LOOP-DO-FOR  
 (defvar *loop-iteration-variables*)     ; LOOP-MAKE-ITERATION-VARIABLE  
 (defvar *loop-iteration-variablep*)     ; ditto  
 (defvar *loop-collect-cruft*)           ; for multiple COLLECTs (etc)  
 (defvar *loop-source-code*)  
 (defvar *loop-duplicate-code* nil)      ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC  
   
687    
688  ;;;; Construct a value return  ;;;This is T if we have emitted any body code, so that iteration driving
689    ;;;clauses can be disallowed.   This is not strictly the same as
690    ;;;checking *loop-body*, because we permit some clauses  such as RETURN
691    ;;;to not be considered "real" body (so as to permit the user to "code"
692    ;;;an  abnormal return value "in loop").
693    (defvar *loop-emitted-body*)
694    
695    
696    ;;;List of epilogue forms (supplied by FINALLY generally), accumulated
697    ;;; in reverse order.
698    (defvar *loop-epilogue*)
699    
700    ;;;List of epilogue forms which are supplied after the above "user"
701    ;;;epilogue.  "normal" termination return values are provide by putting
702    ;;;the return form in here.  Normally this is done using
703    ;;;loop-emit-final-value, q.v.
704    (defvar *loop-after-epilogue*)
705    
706    ;;;The "culprit" responsible for supplying a final value from the loop.
707    ;;;This  is so loop-emit-final-value can moan about multiple return
708    ;;;values being supplied.
709    (defvar *loop-final-value-culprit*)
710    
711    ;;;If not NIL, we are in some branch of a conditional.  Some clauses may
712    ;;;be disallowed.
713    (defvar *loop-inside-conditional*)
714    
715    ;;;If not NIL, this is a temporary bound around the loop for holding the
716    ;;;temporary  value for "it" in things like "when (f) collect it".  It
717    ;;;may be used as a supertemporary by some other things.
718    (defvar *loop-when-it-variable*)
719    
720    ;;;Sometimes we decide we need to fold together parts of the loop, but
721    ;;;some part of the generated iteration  code is different for the first
722    ;;;and remaining iterations.  This variable will be the temporary which
723    ;;;is the flag used in the loop to tell whether we are in the first or
724    ;;;remaining iterations.
725    (defvar *loop-never-stepped-variable*)
726    
727    ;;;List of all the value-accumulation descriptor structures in the loop.
728    ;;; See loop-get-collection-info.
729    (defvar *loop-collection-cruft*)                ; for multiple COLLECTs (etc)
730    
731    
732    ;;;; Code Analysis Stuff
733    
734    
735    (defun loop-constant-fold-if-possible (form &optional expected-type)
736      #+Genera (declare (values new-form constantp constant-value))
737      (let ((new-form form) (constantp nil) (constant-value nil))
738        #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment*
739                                                        :repeat t
740                                                        :do-macro-expansion t
741                                                        :do-named-constants t
742                                                        :do-inline-forms t
743                                                        :do-optimizers t
744                                                        :do-constant-folding t
745                                                        :do-function-args t)
746                       constantp (constantp new-form *loop-macro-environment*)
747                       constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*)))
748        #-Genera (when (setq constantp (constantp new-form))
749                   (setq constant-value (eval new-form)))
750        (when (and constantp expected-type)
751          (unless (typep constant-value expected-type)
752            (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
753                       form constant-value expected-type)
754            (setq constantp nil constant-value nil)))
755        (values new-form constantp constant-value)))
756    
757    
758  (defun loop-construct-return (form)  (defun loop-constantp (form)
759    (if *loop-prog-names*    #+Genera (constantp form *loop-macro-environment*)
760        `(return-from ,(car *loop-prog-names*) ,form)    #-Genera (constantp form))
       `(return ,form)))  
761    
 ;;;; Token Hackery  
762    
763  ;Compare two "tokens".  The first is the frob out of *LOOP-SOURCE-CODE*,  ;;;; LOOP Iteration Optimization
 ;the second a symbol to check against.  
764    
765  (defun loop-tequal (x1 x2)  (defvar *loop-duplicate-code*
766    (and (symbolp x1) (string= x1 x2)))          nil)
767    
768    
769  (defun loop-tassoc (kwd alist)  (defvar *loop-iteration-flag-variable*
770    (and (symbolp kwd) (assoc kwd alist :test #'string=)))          (make-symbol "LOOP-NOT-FIRST-TIME"))
771    
772    
773    (defun loop-code-duplication-threshold (env)
774      (multiple-value-bind (speed space) (loop-optimization-quantities env)
775        (+ 40 (* (- speed space) 10))))
776    
777    
778    (defmacro loop-body (&environment env
779                         prologue
780                         before-loop
781                         main-body
782                         after-loop
783                         epilogue
784                         &aux rbefore rafter flagvar)
785      (unless (= (length before-loop) (length after-loop))
786        (error "LOOP-BODY called with non-synched before- and after-loop lists."))
787      ;;All our work is done from these copies, working backwards from the end:
788      (setq rbefore (reverse before-loop) rafter (reverse after-loop))
789      (labels ((psimp (l)
790                 (let ((ans nil))
791                   (dolist (x l)
792                     (when x
793                       (push x ans)
794                       (when (and (consp x) (member (car x) '(go return return-from)))
795                         (return nil))))
796                   (nreverse ans)))
797               (pify (l) (if (null (cdr l)) (car l) `(progn ,@l)))
798               (makebody ()
799                 (let ((form `(tagbody
800                                ,@(psimp (append prologue (nreverse rbefore)))
801                             next-loop
802                                ,@(psimp (append main-body (nreconc rafter `((go next-loop)))))
803                             end-loop
804                                ,@(psimp epilogue))))
805                   (if flagvar `(let ((,flagvar nil)) ,form) form))))
806        (when (or *loop-duplicate-code* (not rbefore))
807          (return-from loop-body (makebody)))
808        ;; This outer loop iterates once for each not-first-time flag test generated
809        ;; plus once more for the forms that don't need a flag test
810        (do ((threshold (loop-code-duplication-threshold env))) (nil)
811          (declare (fixnum threshold))
812          ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent
813          ;; forms into the body.
814          (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter)))))
815            (push (pop rbefore) main-body)
816            (pop rafter))
817          (unless rbefore (return (makebody)))
818          ;; The first forms in rbefore & rafter (which are the chronologically
819          ;; last forms in the list) differ, therefore they cannot be moved
820          ;; into the main body.  If everything that chronologically precedes
821          ;; them either differs or is equal but is okay to duplicate, we can
822          ;; just put all of rbefore in the prologue and all of rafter after
823          ;; the body.  Otherwise, there is something that is not okay to
824          ;; duplicate, so it and everything chronologically after it in
825          ;; rbefore and rafter must go into the body, with a flag test to
826          ;; distinguish the first time around the loop from later times.
827          ;; What chronologically precedes the non-duplicatable form will
828          ;; be handled the next time around the outer loop.
829          (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil))
830              ((null bb) (return-from loop-body (makebody)))        ;Did it.
831            (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0))
832                  ((or (not (setq inc (estimate-code-size (car bb) env)))
833                       (> (incf count inc) threshold))
834                   ;; Ok, we have found a non-duplicatable piece of code.  Everything
835                   ;; chronologically after it must be in the central body.
836                   ;; Everything chronologically at and after lastdiff goes into the
837                   ;; central body under a flag test.
838                   (let ((then nil) (else nil))
839                     (do () (nil)
840                       (push (pop rbefore) else)
841                       (push (pop rafter) then)
842                       (when (eq rbefore (cdr lastdiff)) (return)))
843                     (unless flagvar
844                       (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else))
845                     (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
846                           main-body))
847                   ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb)
848                   ;; is the same in rbefore and rafter so just copy it into the body
849                   (do () (nil)
850                     (pop rafter)
851                     (push (pop rbefore) main-body)
852                     (when (eq rbefore (cdr bb)) (return)))
853                   (return)))))))
854    
855    
856    
857    (defun duplicatable-code-p (expr env)
858      (if (null expr) 0
859          (let ((ans (estimate-code-size expr env)))
860            (declare (fixnum ans))
861            ;; Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of
862            ;; optimize quantities back to help quantify how much code we are willing to
863            ;; duplicate.
864            ans)))
865    
866    
867    (defvar *special-code-sizes*
868            '((return 0) (progn 0)
869              (null 1) (not 1) (eq 1) (car 1) (cdr 1)
870              (when 1) (unless 1) (if 1)
871              (caar 2) (cadr 2) (cdar 2) (cddr 2)
872              (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3)
873              (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4)
874              (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4)
875              (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4)
876              (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4)))
877    
878    
879    (defvar *estimate-code-size-punt*
880            '(block
881               do do* dolist
882               flet
883               labels lambda let let* locally
884               macrolet multiple-value-bind
885               prog prog*
886               symbol-macrolet
887               tagbody
888               unwind-protect
889               with-open-file))
890    
891    
892    (defun destructuring-size (x)
893      (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n)))
894          ((atom x) (+ n (if (null x) 0 1)))))
895    
896    
897    (defun estimate-code-size (x env)
898      (catch 'estimate-code-size
899        (estimate-code-size-1 x env)))
900    
901    
902    (defun estimate-code-size-1 (x env)
903      (flet ((list-size (l)
904               (let ((n 0))
905                 (declare (fixnum n))
906                 (dolist (x l n) (incf n (estimate-code-size-1 x env))))))
907        ;; ???? (declare (function list-size (list) fixnum))
908        (cond ((constantp x #+Genera env) 1)
909              ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
910                             (if expanded-p (estimate-code-size-1 new-form env) 1)))
911              ((atom x) 1)                          ;??? self-evaluating???
912              ((symbolp (car x))
913               (let ((fn (car x)) (tem nil) (n 0))
914                 (declare (symbol fn) (fixnum n))
915                 (macrolet ((f (overhead &optional (args nil args-p))
916                              `(the fixnum (+ (the fixnum ,overhead)
917                                              (the fixnum (list-size ,(if args-p args '(cdr x))))))))
918                   (cond ((setq tem (get fn 'estimate-code-size))
919                          (typecase tem
920                            (fixnum (f tem))
921                            (t (funcall tem x env))))
922                         ((setq tem (assoc fn *special-code-sizes*)) (f (second tem)))
923                         #+Genera
924                         ((eq fn 'compiler:invisible-references) (list-size (cddr x)))
925                         ((eq fn 'cond)
926                          (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n)))
927                         ((eq fn 'desetq)
928                          (do ((l (cdr x) (cdr l))) ((null l) n)
929                            (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env)))))
930                         ((member fn '(setq psetq))
931                          (do ((l (cdr x) (cdr l))) ((null l) n)
932                            (setq n (+ n (estimate-code-size-1 (cadr l) env) 1))))
933                         ((eq fn 'go) 1)
934                         ((eq fn 'function)
935                          ;;This skirts the issue of implementationally-defined lambda macros
936                          ;; by recognizing CL function names and nothing else.
937                          (if (or (symbolp (cadr x))
938                                  (and (consp (cadr x)) (eq (caadr x) 'setf)))
939                              1
940                              (throw 'duplicatable-code-p nil)))
941                         ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x)))
942                         ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env)))
943                         ((or (special-operator-p fn) (member fn *estimate-code-size-punt*))
944                          (throw 'estimate-code-size nil))
945                         (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
946                              (if expanded-p
947                                  (estimate-code-size-1 new-form env)
948                                  (f 3))))))))
949              (t (throw 'estimate-code-size nil)))))
950    
951    
952    ;;;; Loop Errors
953    
 (defun loop-tmember (kwd list)  
   (and (symbolp kwd) (member kwd list :test #'string=)))  
   
954    
955    (defun loop-context ()
956      (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new)))
957          ((eq l (cdr *loop-source-code*)) (nreverse new))))
958    
 (defmacro define-loop-macro (keyword)  
   "Makes KEYWORD, which is a LOOP keyword, into a Lisp macro that may  
 introduce a LOOP form.  This facility exists mostly for diehard users of  
 a predecessor of LOOP.  Unconstrained use is not advised, as it tends to  
 decrease the transportability of the code and needlessly uses up a  
 function name."  
   (or (eq keyword 'loop)  
       (loop-tassoc keyword +loop-keyword-alist+)  
       (loop-tassoc keyword +loop-iteration-keyword-alist+)  
       (loop-simple-error "not a loop keyword - define-loop-macro" keyword))  
   `(defmacro ,keyword (&whole whole-form  &environment env &rest keywords-and-forms)  
      (declare (ignore keywords-and-forms))  
      (loop-translate whole-form env)))  
959    
960    (defun loop-error (format-string &rest format-args)
961      #+(or Genera CLOE) (declare (dbg:error-reporter))
962      #+Genera (setq format-args (copy-list format-args))   ;Don't ask.
963      (error "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context)))
964    
 (define-loop-macro loop)  
965    
966    (defun loop-warn (format-string &rest format-args)
967      (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context)))
968    
969    
970    (defun loop-check-data-type (specified-type required-type
971                                 &optional (default-type required-type))
972      (if (null specified-type)
973          default-type
974          (multiple-value-bind (a b) (subtypep specified-type required-type)
975            (cond ((not b)
976                   (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S."
977                              specified-type required-type))
978                  ((not a)
979                   (loop-error "Specified data type ~S is not a subtype of ~S."
980                               specified-type required-type)))
981            specified-type)))
982    
983    
984    ;;;INTERFACE: Traditional, ANSI, Lucid.
985  (defmacro loop-finish ()  (defmacro loop-finish ()
986    "Causes the iteration to terminate \"normally\", the same as implicit    "Causes the iteration to terminate \"normally\", the same as implicit
987  termination by an iteration driving clause, or by use of WHILE or  termination by an iteration driving clause, or by use of WHILE or
# Line 338  collected result will be returned as the Line 990  collected result will be returned as the
990    '(go end-loop))    '(go end-loop))
991    
992    
993  (defun loop-translate (x *loop-macro-environment*)  
   (loop-translate-1 x))  
   
   
 (defun loop-end-testify (list-of-forms)  
     (if (null list-of-forms) nil  
         `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))  
                     (car list-of-forms)  
                     (cons 'or list-of-forms))  
            (go end-loop))))  
   
 (defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b  
                                                lastdiff)  
     (do ((l1 (nreverse *loop-before-loop*) (cdr l1))  
          (l2 (nreverse *loop-after-body*) (cdr l2)))  
         ((equal l1 l2)  
            (setq *loop-body* (nconc (delete nil l1) (nreverse *loop-body*))))  
       (push (car l1) before) (push (car l2) after))  
     (cond ((not (null *loop-duplicate-code*))  
              (setq *loop-before-loop* (nreverse (delete nil before))  
                    *loop-after-body* (nreverse (delete nil after))))  
           (t (setq *loop-before-loop* nil *loop-after-body* nil  
                    before (nreverse before) after (nreverse after))  
              (do ((bb before (cdr bb)) (aa after (cdr aa)))  
                  ((null aa))  
                (cond ((not (equal (car aa) (car bb))) (setq lastdiff aa))  
                      ((not (loop-simplep (car aa)))     ;Mustn't duplicate  
                       (return nil))))  
              (cond (lastdiff  ;Down through lastdiff should be duplicated  
                     (do nil (nil)  
                       (and (car before) (push (car before) *loop-before-loop*))  
                       (and (car after) (push (car after) *loop-after-body*))  
                       (setq before (cdr before) after (cdr after))  
                       (and (eq after (cdr lastdiff)) (return nil)))  
                     (setq *loop-before-loop* (nreverse *loop-before-loop*)  
                           *loop-after-body* (nreverse *loop-after-body*))))  
              (do ((bb (nreverse before) (cdr bb))  
                   (aa (nreverse after) (cdr aa)))  
                  ((null aa))  
                (setq a (car aa) b (car bb))  
                (cond ((and (null a) (null b)))  
                      ((equal a b)  
                         (loop-output-group groupb groupa)  
                         (push a *loop-body*)  
                         (setq groupb nil groupa nil))  
                      (t (and a (push a groupa)) (and b (push b groupb)))))  
              (loop-output-group groupb groupa)))  
     (and *loop-never-stepped-variable*  
          (push `(setq ,*loop-never-stepped-variable* nil) *loop-after-body*))  
     nil)  
   
   
 (defun loop-output-group (before after)  
     (and (or after before)  
          (let ((v (or *loop-never-stepped-variable*  
                       (setq *loop-never-stepped-variable*  
                             (loop-make-variable  
                               (loop-gentemp 'loop-iter-flag-) t nil)))))  
             (push (cond ((not before)  
                           `(unless ,v (progn ,@after)))  
                         ((not after)  
                           `(when ,v (progn ,@before)))  
                         (t `(cond (,v ,@before) (t ,@after))))  
                   *loop-body*))))  
   
   
 (defun loop-translate-1 (*loop-source-code*)  
   (and (eq (car *loop-source-code*) 'loop)  
        (setq *loop-source-code* (cdr *loop-source-code*)))  
   (do* ((*loop-iteration-variables* nil)  
        (*loop-iteration-variablep* nil)  
        (*loop-variables* nil)  
        (*loop-nodeclare* nil)  
        (*loop-named-variables* nil)  
        (*loop-declarations* nil)  
        (*loop-desetq-crocks* nil)  
        (*loop-variable-stack* nil)  
        (*loop-declaration-stack* nil)  
        (*loop-desetq-stack* nil)  
        (*loop-prologue* nil)  
        (*loop-wrappers* nil)  
        (*loop-before-loop* nil)  
        (*loop-body* nil)  
        (*loop-emitted-body?* nil)  
        (*loop-after-body* nil)  
        (*loop-epilogue* nil)  
        (*loop-after-epilogue* nil)  
        (*loop-conditionals* nil)  
        (*loop-when-it-variable* nil)  
        (*loop-never-stepped-variable* nil)  
        (*loop-desetq-temporary* nil)  
        (*loop-prog-names* nil)  
        (*loop-collect-cruft* nil)  
        (keyword)  
        (tem)  
        (progvars))  
       ((null *loop-source-code*)  
        (and *loop-conditionals*  
             (loop-simple-error "Hanging conditional in loop macro"  
                                (caadar *loop-conditionals*)))  
        (loop-optimize-duplicated-code-etc)  
        (loop-bind-block)  
        (and *loop-desetq-temporary* (push *loop-desetq-temporary* progvars))  
        (setq tem `(block ,(car *loop-prog-names*)  
                     (let ,progvars  
                       (tagbody  
                         ,@(nreverse *loop-prologue*)  
                         ,@*loop-before-loop*  
                      next-loop  
                         ,@*loop-body*  
                         ,@*loop-after-body*  
                         (go next-loop)  
                         (go end-loop)  
                      end-loop  
                         ,@(nreverse *loop-epilogue*)  
                         ,@(nreverse *loop-after-epilogue*)))))  
        (do ((vars) (dcls) (crocks))  
            ((null *loop-variable-stack*))  
          (setq vars (car *loop-variable-stack*)  
                *loop-variable-stack* (cdr *loop-variable-stack*)  
                dcls (car *loop-declaration-stack*)  
                *loop-declaration-stack* (cdr *loop-declaration-stack*)  
                tem (list tem))  
          (and (setq crocks (pop *loop-desetq-stack*))  
               (push (loop-make-desetq crocks) tem))  
          (and dcls (push (cons 'declare dcls) tem))  
          ;; JJGR -- Avoid building LAMBDAs as far as possible  
          (setq tem `(let ,(nreverse vars) ,@tem))  
          #+nil  
          (cond ((do ((l vars (cdr l))) ((null l) nil)  
                   (and (not (atom (car l)))  
                        (or (null (caar l)) (not (symbolp (caar l))))  
                        (return t)))  
                   (setq tem `(let ,(nreverse vars) ,@tem)))  
                (t (let ((lambda-vars nil) (lambda-vals nil))  
                     (do ((l vars (cdr l)) (v)) ((null l))  
                       (cond ((atom (setq v (car l)))  
                                (push v lambda-vars)  
                                (push nil lambda-vals))  
                             (t (push (car v) lambda-vars)  
                                (push (cadr v) lambda-vals))))  
                     (setq tem `((lambda ,lambda-vars ,@tem)  
                                 ,@lambda-vals))))))  
        (do ((l *loop-wrappers* (cdr l))) ((null l))  
          (setq tem (append (car l) (list tem))))  
        tem)  
     ;;The following commented-out code is what comes from the newest source  
     ;; code in use in NIL.  The code in use following it comes from about version  
     ;; 803, that in use in symbolics release 6.1, for instance.  To turn on the  
     ;; implicit DO feature, switch them and fix loop-get-form to just pop the source.  
     (if (symbolp (setq keyword (car *loop-source-code*)))  
         (loop-pop-source)  
       (setq keyword 'do))  
     (cond ((setq tem (loop-tassoc keyword +loop-keyword-alist+))  
            (apply (cadr tem) (cddr tem)))  
           ((setq tem (loop-tassoc keyword +loop-iteration-keyword-alist+))  
            (loop-hack-iteration tem))  
           ((loop-tmember keyword '(and else))  
            ;; Alternative is to ignore it, ie let it go around to the  
            ;; next keyword...  
            (loop-simple-error  
             "secondary clause misplaced at top level in LOOP macro"  
             (list keyword (car *loop-source-code*)  
                   (cadr *loop-source-code*))))  
           (t (loop-simple-error "unknown keyword in LOOP macro" keyword)))  
     ;;    (if (symbolp (setq keyword (loop-pop-source)))  
     ;;  (if (setq tem (loop-tassoc keyword +loop-keyword-alist+))  
     ;;      (apply (cadr tem) (cddr tem))  
     ;;      (if (setq tem (loop-tassoc  
     ;;                       keyword +loop-iteration-keyword-alist+))  
     ;;          (loop-hack-iteration tem)  
     ;;          (if (loop-tmember keyword '(and else))  
     ;;              ; Alternative is to ignore it, ie let it go around to the  
     ;;              ; next keyword...  
     ;;              (loop-simple-error  
     ;;                 "secondary clause misplaced at top level in LOOP macro"  
     ;;                 (list keyword (car *loop-source-code*)  
     ;;                       (cadr *loop-source-code*)))  
     ;;              (loop-simple-error  
     ;;                 "unknown keyword in LOOP macro" keyword))))  
     ;;  (loop-simple-error  
     ;;     "found where keyword expected in LOOP macro" keyword))  
 ))  
994    
995    (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*)
996      (let ((*loop-original-source-code* *loop-source-code*)
997            (*loop-source-context* nil)
998            (*loop-iteration-variables* nil)
999            (*loop-variables* nil)
1000            (*loop-nodeclare* nil)
1001            (*loop-named-variables* nil)
1002            (*loop-declarations* nil)
1003            (*loop-desetq-crocks* nil)
1004            (*loop-bind-stack* nil)
1005            (*loop-prologue* nil)
1006            (*loop-wrappers* nil)
1007            (*loop-before-loop* nil)
1008            (*loop-body* nil)
1009            (*loop-emitted-body* nil)
1010            (*loop-after-body* nil)
1011            (*loop-epilogue* nil)
1012            (*loop-after-epilogue* nil)
1013            (*loop-final-value-culprit* nil)
1014            (*loop-inside-conditional* nil)
1015            (*loop-when-it-variable* nil)
1016            (*loop-never-stepped-variable* nil)
1017            (*loop-names* nil)
1018            (*loop-collection-cruft* nil))
1019        (loop-iteration-driver)
1020        (loop-bind-block)
1021        (let ((answer `(loop-body
1022                         ,(nreverse *loop-prologue*)
1023                         ,(nreverse *loop-before-loop*)
1024                         ,(nreverse *loop-body*)
1025                         ,(nreverse *loop-after-body*)
1026                         ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))
1027          (do () (nil)
1028            (setq answer `(block ,(pop *loop-names*) ,answer))
1029            (unless *loop-names* (return nil)))
1030          (dolist (entry *loop-bind-stack*)
1031            (let ((vars (first entry))
1032                  (dcls (second entry))
1033                  (crocks (third entry))
1034                  (wrappers (fourth entry)))
1035              (dolist (w wrappers)
1036                (setq answer (append w (list answer))))
1037              (when (or vars dcls crocks)
1038                (let ((forms (list answer)))
1039                  ;;(when crocks (push crocks forms))
1040                  (when dcls (push `(declare ,@dcls) forms))
1041                  (setq answer `(,(cond ((not vars) 'locally)
1042                                        (*loop-destructuring-hooks* (first *loop-destructuring-hooks*))
1043                                        (t 'let))
1044                                 ,vars
1045                                 ,@(if crocks
1046                                       `((destructuring-bind ,@crocks
1047                                             ,@forms))
1048                                     forms)))))))
1049          answer)))
1050    
1051    
1052    (defun loop-iteration-driver ()
1053      (do () ((null *loop-source-code*))
1054        (let ((keyword (car *loop-source-code*)) (tem nil))
1055          (cond ((not (symbolp keyword))
1056                 (loop-error "~S found where LOOP keyword expected." keyword))
1057                (t (setq *loop-source-context* *loop-source-code*)
1058                   (loop-pop-source)
1059                   (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*)))
1060                          ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.)
1061                          (apply (symbol-function (first tem)) (rest tem)))
1062                         ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*)))
1063                          (loop-hack-iteration tem))
1064                         ((loop-tmember keyword '(and else))
1065                          ;; Alternative is to ignore it, ie let it go around to the next keyword...
1066                          (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
1067                                      keyword (car *loop-source-code*) (cadr *loop-source-code*)))
1068                         (t (loop-error "~S is an unknown keyword in LOOP macro." keyword))))))))
1069    
1070    
1071    
1072    (defun loop-pop-source ()
1073      (if *loop-source-code*
1074          (pop *loop-source-code*)
1075          (loop-error "LOOP source code ran out when another token was expected.")))
1076    
 (defun loop-bind-block ()  
    (cond ((not (null *loop-variables*))  
             (push *loop-variables* *loop-variable-stack*)  
             (push *loop-declarations* *loop-declaration-stack*)  
             (setq *loop-variables* nil *loop-declarations* nil)  
             (push *loop-desetq-crocks* *loop-desetq-stack*)  
             (setq *loop-desetq-crocks* nil))))  
   
1077    
1078  ;Get FORM argument to a keyword.  Read up to atom.  PROGNify if necessary.  (defun loop-get-progn ()
 (defun loop-get-progn-1 ()  
1079    (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms))    (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms))
1080         (nextform (car *loop-source-code*) (car *loop-source-code*)))         (nextform (car *loop-source-code*) (car *loop-source-code*)))
1081        ((atom nextform) (nreverse forms))))        ((atom nextform)
1082           (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms))))))
1083    
 (defun loop-get-progn ()  
   (let ((forms (loop-get-progn-1)))  
     (if (null (cdr forms)) (car forms) (cons 'progn forms))))  
1084    
1085  (defun loop-get-form (for)  (defun loop-get-form ()
1086    ;; Until implicit DO is installed, use the following.  Then, replace it with    (if *loop-source-code*
1087    ;; just loop-pop-source.        (loop-pop-source)
1088    (let ((forms (loop-get-progn-1)))        (loop-error "LOOP code ran out where a form was expected.")))
1089      (cond ((null (cdr forms)) (car forms))  
1090            (t (loop-warn  
1091  "The use of multiple forms with an implicit PROGN in this context  (defun loop-construct-return (form)
1092  is considered obsolete, but is still supported for the time being.    `(return-from ,(car *loop-names*) ,form))
1093  If you did not intend to use multiple forms here, you probably omitted a DO.  
1094  If the use of multiple forms was intentional, put a PROGN in your code.  
1095  The offending clause"  (defun loop-pseudo-body (form)
1096                  (if (atom for) (cons for forms) (append for forms)))    (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*))
1097               (cons 'progn forms)))))          (t (push form *loop-before-loop*) (push form *loop-after-body*))))
1098    
1099    (defun loop-emit-body (form)
1100  ;;;This function takes a substitutable expression containing generic arithmetic    (setq *loop-emitted-body* t)
1101  ;;; of some form or another, and a data type name, and substitutes for the function    (loop-pseudo-body form))
1102  ;;; any type-specific functions for that type in the implementation.  
1103  (defun loop-typed-arith (substitutable-expression data-type)  (defun loop-emit-final-value (form)
1104    (declare (ignore data-type))    (push (loop-construct-return form) *loop-after-epilogue*)
1105    substitutable-expression)    (when *loop-final-value-culprit*
1106        (loop-warn "LOOP clause is providing a value for the iteration,~@
1107                    however one was already established by a ~S clause."
1108                   *loop-final-value-culprit*))
1109      (setq *loop-final-value-culprit* (car *loop-source-context*)))
1110    
1111    
1112    (defun loop-disallow-conditional (&optional kwd)
1113      #+(or Genera CLOE) (declare (dbg:error-reporter))
1114      (when *loop-inside-conditional*
1115        (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd)))
1116    
1117    
1118    ;;;; Loop Types
1119    
 (defvar loop-floating-point-types  
         '(flonum float short-float single-float double-float long-float))  
1120    
1121  (defun loop-typed-init (data-type)  (defun loop-typed-init (data-type)
1122    (let ((tem nil))    (when (and data-type (subtypep data-type 'number))
1123      (cond ((loop-tmember data-type '(fixnum integer number)) 0)      (if (or (subtypep data-type 'float) (subtypep data-type '(complex float)))
1124            ((setq tem (car (loop-tmember          (coerce 0 data-type)
1125                              data-type loop-floating-point-types)))          0)))
1126             (cond ((member tem '(flonum float)) 0.0)  
1127                   (t (coerce 0 tem)))))))  
1128    (defun loop-optional-type (&optional variable)
1129      ;;No variable specified implies that no destructuring is permissible.
1130      (and *loop-source-code*                       ;Don't get confused by NILs...
1131           (let ((z (car *loop-source-code*)))
1132             (cond ((loop-tequal z 'of-type)
1133                    ;;This is the syntactically unambigous form in that the form of the
1134                    ;; type specifier does not matter.  Also, it is assumed that the
1135                    ;; type specifier is unambiguously, and without need of translation,
1136                    ;; a common lisp type specifier or pattern (matching the variable) thereof.
1137                    (loop-pop-source)
1138                    (loop-pop-source))
1139                          
1140                   ((symbolp z)
1141                    ;;This is the (sort of) "old" syntax, even though we didn't used to support all of
1142                    ;; these type symbols.
1143                    (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*))
1144                                         (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*)))))
1145                      (when type-spec
1146                        (loop-pop-source)
1147                        type-spec)))
1148                   (t
1149                    ;;This is our sort-of old syntax.  But this is only valid for when we are destructuring,
1150                    ;; so we will be compulsive (should we really be?) and require that we in fact be
1151                    ;; doing variable destructuring here.  We must translate the old keyword pattern typespec
1152                    ;; into a fully-specified pattern of real type specifiers here.
1153                    (if (consp variable)
1154                        (unless (consp z)
1155                         (loop-error
1156                            "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected."
1157                            z))
1158                        (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z))
1159                    (loop-pop-source)
1160                    (labels ((translate (k v)
1161                               (cond ((null k) nil)
1162                                     ((atom k)
1163                                      (replicate
1164                                        (or (gethash k (loop-universe-type-symbols *loop-universe*))
1165                                            (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*))
1166                                            (loop-error
1167                                              "Destructuring type pattern ~S contains unrecognized type keyword ~S."
1168                                              z k))
1169                                        v))
1170                                     ((atom v)
1171                                      (loop-error
1172                                        "Destructuring type pattern ~S doesn't match variable pattern ~S."
1173                                        z variable))
1174                                     (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v))))))
1175                             (replicate (typ v)
1176                               (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v))))))
1177                      (translate z variable)))))))
1178    
1179    
1180  (defun loop-make-variable (name initialization dtype)  
1181    ;;;; Loop Variables
1182    
1183    
1184    (defun loop-bind-block ()
1185      (when (or *loop-variables* *loop-declarations* *loop-wrappers*)
1186        (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*)
1187              *loop-bind-stack*)
1188        (setq *loop-variables* nil
1189              *loop-declarations* nil
1190              *loop-desetq-crocks* nil
1191              *loop-wrappers* nil)))
1192    
1193    
1194    (defun loop-make-variable (name initialization dtype &optional iteration-variable-p)
1195    (cond ((null name)    (cond ((null name)
1196             (cond ((not (null initialization))           (cond ((not (null initialization))
1197                      (push (list (setq name (loop-gentemp 'loop-ignore-))                  (push (list (setq name (loop-gentemp 'loop-ignore-))
1198                                  initialization)                              initialization)
1199                            *loop-variables*)                        *loop-variables*)
1200                        (push `(ignore ,name) *loop-declarations*))))                  (push `(ignore ,name) *loop-declarations*))))
1201          ((atom name)          ((atom name)
1202             (cond (*loop-iteration-variablep*           (cond (iteration-variable-p
1203                      (if (member name *loop-iteration-variables*)                  (if (member name *loop-iteration-variables*)
1204                          (loop-simple-error                      (loop-error "Duplicated LOOP iteration variable ~S." name)
1205                             "Duplicated iteration variable somewhere in LOOP"                      (push name *loop-iteration-variables*)))
1206                             name)                 ((assoc name *loop-variables*)
1207                          (push name *loop-iteration-variables*)))                  (loop-error "Duplicated variable ~S in LOOP parallel binding." name)))
1208                   ((assoc name *loop-variables*)           (unless (symbolp name)
1209                      (loop-simple-error             (loop-error "Bad variable ~S somewhere in LOOP." name))
1210                         "Duplicated var in LOOP bind block" name)))           (loop-declare-variable name dtype)
1211             (or (symbolp name)           ;; We use ASSOC on this list to check for duplications (above),
1212                 (loop-simple-error "Bad variable somewhere in LOOP" name))           ;; so don't optimize out this list:
1213             (loop-declare-variable name dtype)           (push (list name (or initialization (loop-typed-init dtype)))
1214             ; We use ASSOC on this list to check for duplications (above),                 *loop-variables*))
            ; so don't optimize out this list:  
            (push (list name (or initialization (loop-typed-init dtype)))  
                  *loop-variables*))  
1215          (initialization          (initialization
1216             (cond (*loop-use-system-destructuring?*           (cond (*loop-destructuring-hooks*
1217                      (loop-declare-variable name dtype)                  (loop-declare-variable name dtype)
1218                      (push (list name initialization) *loop-variables*))                  (push (list name initialization) *loop-variables*))
1219                   (t (let ((newvar (loop-gentemp 'loop-destructure-)))                 (t (let ((newvar (loop-gentemp 'loop-destructure-)))
1220                        (push (list newvar initialization) *loop-variables*)                      (push (list newvar initialization) *loop-variables*)
1221                        ; *LOOP-DESETQ-CROCKS* gathered in reverse order.                      ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
1222                        (setq *loop-desetq-crocks*                      (setq *loop-desetq-crocks*
1223                              (list* name newvar *loop-desetq-crocks*))                        (list* name newvar *loop-desetq-crocks*))
1224                        (loop-make-variable name nil dtype)))))                      #+ignore
1225                        (loop-make-variable name nil dtype iteration-variable-p)))))
1226          (t (let ((tcar nil) (tcdr nil))          (t (let ((tcar nil) (tcdr nil))
1227               (if (atom dtype) (setq tcar (setq tcdr dtype))               (if (atom dtype) (setq tcar (setq tcdr dtype))
1228                 (setq tcar (car dtype) tcdr (cdr dtype)))                   (setq tcar (car dtype) tcdr (cdr dtype)))
1229               (loop-make-variable (car name) nil tcar)               (loop-make-variable (car name) nil tcar iteration-variable-p)
1230               (loop-make-variable (cdr name) nil tcdr))))               (loop-make-variable (cdr name) nil tcdr iteration-variable-p))))
1231    name)    name)
1232    
1233    
1234  (defun loop-make-iteration-variable (name initialization dtype)  (defun loop-make-iteration-variable (name initialization dtype)
1235      (let ((*loop-iteration-variablep* t))    (loop-make-variable name initialization dtype t))
        (loop-make-variable name initialization dtype)))  
1236    
1237    
1238  (defun loop-declare-variable (name dtype)  (defun loop-declare-variable (name dtype)
1239      (cond ((or (null name) (null dtype)) nil)    (cond ((or (null name) (null dtype) (eq dtype t)) nil)
1240            ((and (symbolp name) (not (member name *loop-nodeclare*)))          ((symbolp name)
1241             (push `(type ,(if (loop-tequal dtype 'notype) t dtype) ,name)           (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
1242                   *loop-declarations*))             (let ((dtype #-cmu dtype
1243            ((consp name)                          #+cmu
1244                (cond ((consp dtype)                          (let ((init (loop-typed-init dtype)))
1245                         (loop-declare-variable (car name) (car dtype))                            (if (typep init dtype)
1246                         (loop-declare-variable (cdr name) (cdr dtype)))                                dtype
1247                      (t (loop-declare-variable (car name) dtype)                                `(or (member ,init) ,dtype)))))
1248                         (loop-declare-variable (cdr name) dtype))))               (push `(type ,dtype ,name) *loop-declarations*))))
1249            (t (loop-simple-error "can't hack this"          ((consp name)
1250                                  (list 'loop-declare-variable name dtype)))))           (cond ((consp dtype)
1251                    (loop-declare-variable (car name) (car dtype))
1252                    (loop-declare-variable (cdr name) (cdr dtype)))
1253                   (t (loop-declare-variable (car name) dtype)
1254                      (loop-declare-variable (cdr name) dtype))))
1255            (t (error "Invalid LOOP variable passed in: ~S." name))))
1256    
1257    
1258    (defun loop-maybe-bind-form (form data-type)
1259      (if (loop-constantp form)
1260          form
1261          (loop-make-variable (loop-gentemp 'loop-bind-) form data-type)))
1262    
1263    
 (defun loop-constantp (form)  
   (constantp form))  
1264    
1265  (defun loop-maybe-bind-form (form data-type?)  (defun loop-do-if (for negatep)
1266      ; Consider implementations which will not keep EQ quoted constants    (let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil))
1267      ; EQ after compilation & loading.      (flet ((get-clause (for)
1268      ; Note FUNCTION is not hacked, multiple occurences might cause the               (do ((body nil)) (nil)
1269      ; compiler to break the function off multiple times!                 (let ((key (car *loop-source-code*)) (*loop-body* nil) data)
1270      ; Hacking it probably isn't too important here anyway.  The ones that                   (cond ((not (symbolp key))
1271      ; matter are the ones that use it as a stepper (or whatever), which                          (loop-error
1272      ; handle it specially.                            "~S found where keyword expected getting LOOP clause after ~S."
1273      (if (loop-constantp form) form                            key for))
1274          (loop-make-variable (loop-gentemp 'loop-bind-) form data-type?)))                         (t (setq *loop-source-context* *loop-source-code*)
1275                              (loop-pop-source)
1276                              (when (loop-tequal (car *loop-source-code*) 'it)
1277  (defun loop-optional-type ()                              (setq *loop-source-code*
1278      (let ((token (car *loop-source-code*)))                                    (cons (or it-p (setq it-p (loop-when-it-variable)))
1279          (and (not (null token))                                          (cdr *loop-source-code*))))
1280               (or (not (atom token))                            (cond ((or (not (setq data (loop-lookup-keyword
1281                   (loop-tmember token '(fixnum integer number notype))                                                         key (loop-universe-keywords *loop-universe*))))
1282                   (loop-tmember token loop-floating-point-types))                                       (progn (apply (symbol-function (car data)) (cdr data))
1283               (loop-pop-source))))                                              (null *loop-body*)))
1284                                     (loop-error
1285                                       "~S does not introduce a LOOP clause that can follow ~S."
1286  ;Incorporates conditional if necessary                                     key for))
1287  (defun loop-make-conditionalization (form)                                  (t (setq body (nreconc *loop-body* body)))))))
1288    (cond ((not (null *loop-conditionals*))                 (if (loop-tequal (car *loop-source-code*) :and)
1289             (rplacd (last (car (last (car (last *loop-conditionals*)))))                     (loop-pop-source)
1290                     (list form))                     (return (if (cdr body) `(progn ,@(nreverse body)) (car body)))))))
1291             (cond ((loop-tequal (car *loop-source-code*) 'and)        (let ((then (get-clause for))
1292                      (loop-pop-source)              (else (when (loop-tequal (car *loop-source-code*) :else)
                     nil)  
                  ((loop-tequal (car *loop-source-code*) 'else)  
1293                      (loop-pop-source)                      (loop-pop-source)
1294                      ;; If we are already inside an else clause, close it off                      (list (get-clause :else)))))
1295                      ;; and nest it inside the containing when clause          (when (loop-tequal (car *loop-source-code*) :end)
1296                      (let ((innermost (car (last *loop-conditionals*))))            (loop-pop-source))
1297                        (cond ((null (cddr innermost)))   ;Now in a WHEN clause, OK          (when it-p (setq form `(setq ,it-p ,form)))
1298                              ((null (cdr *loop-conditionals*))          (loop-pseudo-body
1299                               (loop-simple-error "More ELSEs than WHENs"            `(if ,(if negatep `(not ,form) form)
1300                                                  (list 'else (car *loop-source-code*)                 ,then
1301                                                        (cadr *loop-source-code*))))                 ,@else))))))
                             (t (setq *loop-conditionals* (cdr (nreverse *loop-conditionals*)))  
                                (rplacd (last (car (last (car *loop-conditionals*))))  
                                        (list innermost))  
                                (setq *loop-conditionals* (nreverse *loop-conditionals*)))))  
                     ;; Start a new else clause  
                     (rplacd (last (car (last *loop-conditionals*)))  
                             (list (list 't)))  
                     nil)  
                  (t ;Nest up the conditionals and output them  
                      (do ((prev (car *loop-conditionals*) (car l))  
                           (l (cdr *loop-conditionals*) (cdr l)))  
                          ((null l))  
                        (rplacd (last (car (last prev))) (list (car l))))  
                      (prog1 (car *loop-conditionals*)  
                             (setq *loop-conditionals* nil)))))  
         (t form)))  
   
 (defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form)))  
    (cond ((not (null z))  
             (cond (*loop-emitted-body?* (push z *loop-body*))  
                   (t (push z *loop-before-loop*) (push z *loop-after-body*))))))  
   
 (defun loop-emit-body (form)  
   (setq *loop-emitted-body?* t)  
   (loop-pseudo-body form))  
   
1302    
 (defun loop-do-named ()  
   (let ((name (loop-pop-source)))  
     (unless (and name (symbolp name))  
       (loop-simple-error "Bad name for your loop construct" name))  
     ;If this don't come first, LOOP will be confused about how to return  
     ; from the prog when it tries to generate such code  
     (when (or *loop-before-loop* *loop-body* *loop-after-epilogue*)  
       (loop-simple-error "NAMED clause occurs too late" name))  
     (when (cdr (setq *loop-prog-names* (cons name *loop-prog-names*)))  
       (loop-simple-error "Too many names for your loop construct"  
                          *loop-prog-names*))))  
1303    
1304  (defun loop-do-initially ()  (defun loop-do-initially ()
1305      (loop-disallow-conditional :initially)
1306    (push (loop-get-progn) *loop-prologue*))    (push (loop-get-progn) *loop-prologue*))
1307    
 (defun loop-nodeclare (&aux (varlist (loop-pop-source)))  
     (or (null varlist)  
         (consp varlist)  
         (loop-simple-error "Bad varlist to nodeclare loop clause" varlist))  
     (setq *loop-nodeclare* (append varlist *loop-nodeclare*)))  
   
1308  (defun loop-do-finally ()  (defun loop-do-finally ()
1309      (loop-disallow-conditional :finally)
1310    (push (loop-get-progn) *loop-epilogue*))    (push (loop-get-progn) *loop-epilogue*))
1311    
1312  (defun loop-do-do ()  (defun loop-do-do ()
1313    (loop-emit-body (loop-get-progn)))    (loop-emit-body (loop-get-progn)))
1314    
1315    (defun loop-do-named ()
1316      (let ((name (loop-pop-source)))
1317        (unless (symbolp name)
1318          (loop-error "~S is an invalid name for your LOOP." name))
1319        (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*)
1320          (loop-error "The NAMED ~S clause occurs too late." name))
1321        (when *loop-names*
1322          (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S."
1323                      (car *loop-names*) name))
1324        (setq *loop-names* (list name nil))))
1325    
1326  (defun loop-do-return ()  (defun loop-do-return ()
1327     (loop-pseudo-body (loop-construct-return (loop-get-form 'return))))    (loop-pseudo-body (loop-construct-return (loop-get-form))))
1328    
1329    
1330  (defun loop-do-collect (type)  ;;;; Value Accumulation: List
   (let ((var nil) (form nil) (tem nil) (tail nil) (dtype nil) (cruft nil) (rvar nil)  
         (ctype (case type  
                  ((max min) 'maxmin)  
                  ((nconc list append) 'list)  
                  ((count sum) 'sum)  
                  (t (error "LOOP internal error:  ~S is an unknown collecting keyword."  
                            type)))))  
     (setq form (loop-get-form type) dtype (loop-optional-type))  
     (cond ((loop-tequal (car *loop-source-code*) 'into)  
              (loop-pop-source)  
              (setq rvar (setq var (loop-pop-source)))))  
     ; CRUFT will be (varname ctype dtype var tail (optional tem))  
     (cond ((setq cruft (assoc var *loop-collect-cruft*))  
              (cond ((not (eq ctype (car (setq cruft (cdr cruft)))))  
                       (loop-simple-error  
                          "incompatible LOOP collection types"  
                          (list ctype (car cruft))))  
                    ((and dtype (not (eq dtype (cadr cruft))))  
                       ;Conditional should be on data-type reality  
                     (error "~A and ~A Unequal data types into ~A"  
                            dtype (cadr cruft) (car cruft))))  
              (setq dtype (car (setq cruft (cdr cruft)))  
                    var (car (setq cruft (cdr cruft)))  
                    tail (car (setq cruft (cdr cruft)))  
                    tem (cadr cruft))  
              (and (eq ctype 'maxmin)  
                   (not (atom form)) (null tem)  
                   (rplaca (cdr cruft)  
                           (setq tem (loop-make-variable  
                                        (loop-gentemp 'loop-maxmin-)  
                                        nil dtype)))))  
           (t (unless dtype  
                (setq dtype (case type  
                              (count 'fixnum)  
                              ((min max sum) 'number))))  
              (unless var  
                (push (loop-construct-return (setq var (loop-gentemp)))  
                      *loop-after-epilogue*))  
              (loop-make-iteration-variable var nil dtype)  
              (cond ((eq ctype 'maxmin)  
                       ;Make a temporary.  
                       (unless (atom form)  
                         (setq tem (loop-make-variable  
                                     (loop-gentemp) nil dtype)))  
                       ;Use the tail slot of the collect database to hold a  
                       ; flag which says we have been around once already.  
                       (setq tail (loop-make-variable  
                                    (loop-gentemp 'loop-maxmin-fl-) t nil)))  
                    ((eq ctype 'list)  
                     ;For dumb collection, we need both a tail and a flag var  
                     ; to tell us whether we have iterated.  
                     (setq tail (loop-make-variable (loop-gentemp) nil nil)  
                           tem (loop-make-variable (loop-gentemp) nil nil))))  
              (push (list rvar ctype dtype var tail tem)  
                    *loop-collect-cruft*)))  
     (loop-emit-body  
         (case type  
           (count (setq tem `(setq ,var (,(loop-typed-arith '1+ dtype)  
                                         ,var)))  
                  (if (or (eq form t) (equal form ''t))  
                      tem  
                      `(when ,form ,tem)))  
           (sum `(setq ,var (,(loop-typed-arith '+ dtype) ,form ,var)))  
           ((max min)  
              (let ((forms nil) (arglist nil))  
                 ; TEM is temporary, properly typed.  
                 (and tem (setq forms `((setq ,tem ,form)) form tem))  
                 (setq arglist (list var form))  
                 (push (if (loop-tmember dtype '(fixnum flonum))  
                           ; no contagious arithmetic  
                           `(when (or ,tail  
                                      (,(loop-typed-arith  
                                          (if (eq type 'max) '< '>)  
                                          dtype)  
                                       ,@arglist))  
                              (setq ,tail nil ,@arglist))  
                           ; potentially contagious arithmetic -- must use  
                           ; MAX or MIN so that var will be contaminated  
                           `(setq ,var (cond (,tail (setq ,tail nil) ,form)  
                                             (t (,type ,@arglist)))))  
                       forms)  
                 (if (cdr forms) (cons 'progn (nreverse forms)) (car forms))))  
           (t (case type  
                 (list (setq form (list 'list form)))  
                 (append (or (and (not (atom form)) (eq (car form) 'list))  
                             (setq form `(copy-list ,form)))))  
              (let ((q `(if ,tail (cdr (rplacd ,tail ,tem))  
                          (setq ,var ,tem))))  
                 (if (and (not (atom form)) (eq (car form) 'list) (cdr form))  
                     `(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q))  
                     `(when (setq ,tem ,form) (setq ,tail (last ,q))))))))))  
   
   
 (defun loop-cdrify (arglist form)  
     (do ((size (length arglist) (- size 4)))  
         ((< size 4)  
          (if (zerop size) form  
              (list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) (t 'cdddr))  
                    form)))  
       (declare (type fixnum size))  
       (setq form (list 'cddddr form))))  
   
   
   
 (defun loop-do-while (negate? kwd &aux (form (loop-get-form kwd)))  
   (when *loop-conditionals*  
     (loop-simple-error "not allowed inside LOOP conditional"  
                        (list kwd form)))  
   (loop-pseudo-body `(,(if negate? 'when 'unless)  
                       ,form (go end-loop))))  
   
   
 (defun loop-do-when (negate? kwd)  
   (let ((form (loop-get-form kwd)) (cond nil))  
     (cond ((loop-tequal (cadr *loop-source-code*) 'it)  
              ;WHEN foo RETURN IT and the like  
              (setq cond `(setq ,(loop-when-it-variable) ,form))  
              (setq *loop-source-code*           ;Plug in variable for IT  
                    (list* (car *loop-source-code*)  
                           *loop-when-it-variable*  
                           (cddr *loop-source-code*))))  
           (t (setq cond form)))  
     (and negate? (setq cond `(not ,cond)))  
     (setq *loop-conditionals* (nconc *loop-conditionals* `((cond (,cond)))))))  
1331    
1332  (defun loop-do-with ()  
1333    (do ((var) (equals) (val) (dtype)) (nil)  (defstruct (loop-collector
1334      (setq var (loop-pop-source) equals (car *loop-source-code*))               #+ecls (:type vector)
1335      (cond ((loop-tequal equals '=)               #+nil (:copier nil)
1336               (loop-pop-source)               #+nil (:predicate nil))
1337               (setq val (loop-get-form (list 'with var '=)) dtype nil))    name
1338            ((or (loop-tequal equals 'and)    class
1339                 (loop-tassoc equals +loop-keyword-alist+)    (history nil)
1340                 (loop-tassoc equals +loop-iteration-keyword-alist+))    (tempvars nil)
1341               (setq val nil dtype nil))    dtype
1342            (t (setq dtype (loop-optional-type) equals (car *loop-source-code*))    (data nil))                                           ;collector-specific data
1343               (cond ((loop-tequal equals '=)  
1344                        (loop-pop-source)  
1345                        (setq val (loop-get-form (list 'with var dtype '=))))  (defun loop-get-collection-info (collector class default-type)
1346                     ((and (not (null *loop-source-code*))    (let ((form (loop-get-form))
1347                           (not (loop-tassoc equals +loop-keyword-alist+))          (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
1348                           (not (loop-tassoc          (name (when (loop-tequal (car *loop-source-code*) 'into)
1349                                   equals +loop-iteration-keyword-alist+))                  (loop-pop-source)
1350                           (not (loop-tequal equals 'and)))                  (loop-pop-source))))
1351                        (loop-simple-error "Garbage where = expected" equals))      (when (not (symbolp name))
1352                     (t (setq val nil)))))        (loop-error "Value accumulation recipient name, ~S, is not a symbol." name))
1353      (loop-make-variable var val dtype)      (unless dtype
1354      (if (not (loop-tequal (car *loop-source-code*) 'and)) (return nil)        (setq dtype (or (loop-optional-type) default-type)))
1355          (loop-pop-source)))      (let ((cruft (find (the symbol name) *loop-collection-cruft*
1356    (loop-bind-block))                         :key #'loop-collector-name)))
1357          (cond ((not cruft)
1358  (defun loop-do-always (negate?)               (push (setq cruft (make-loop-collector
1359    (let ((form (loop-get-form 'always)))                                   :name name :class class
1360      (loop-emit-body `(,(if negate? 'when 'unless) ,form                                   :history (list collector) :dtype dtype))
1361                       *loop-collection-cruft*))
1362                (t (unless (eq (loop-collector-class cruft) class)
1363                     (loop-error
1364                       "Incompatible kinds of LOOP value accumulation specified for collecting~@
1365                        ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S."
1366                       name (car (loop-collector-history cruft)) collector))
1367                   (unless (equal dtype (loop-collector-dtype cruft))
1368                     (loop-warn
1369                       "Unequal datatypes specified in different LOOP value accumulations~@
1370                       into ~S: ~S and ~S."
1371                       name dtype (loop-collector-dtype cruft))
1372                     (when (eq (loop-collector-dtype cruft) t)
1373                       (setf (loop-collector-dtype cruft) dtype)))
1374                   (push collector (loop-collector-history cruft))))
1375          (values cruft form))))
1376    
1377    
1378    (defun loop-list-collection (specifically)      ;NCONC, LIST, or APPEND
1379      (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list)
1380        (let ((tempvars (loop-collector-tempvars lc)))
1381          (unless tempvars
1382            (setf (loop-collector-tempvars lc)
1383                  (setq tempvars (list* (loop-gentemp 'loop-list-head-)
1384                                        (loop-gentemp 'loop-list-tail-)
1385                                        (and (loop-collector-name lc)
1386                                             (list (loop-collector-name lc))))))
1387            (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*)
1388            (unless (loop-collector-name lc)
1389              (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars)))))
1390          (ecase specifically
1391            (list (setq form `(list ,form)))
1392            (nconc nil)
1393            (append (unless (and (consp form) (eq (car form) 'list))
1394                      (setq form `(loop-copylist* ,form)))))
1395          (loop-emit-body `(loop-collect-rplacd ,tempvars ,form)))))
1396    
1397    
1398    ;;;; Value Accumulation: max, min, sum, count.
1399    
1400    
1401    
1402    (defun loop-sum-collection (specifically required-type default-type)    ;SUM, COUNT
1403      (multiple-value-bind (lc form)
1404          (loop-get-collection-info specifically 'sum default-type)
1405        (loop-check-data-type (loop-collector-dtype lc) required-type)
1406        (let ((tempvars (loop-collector-tempvars lc)))
1407          (unless tempvars
1408            (setf (loop-collector-tempvars lc)
1409                  (setq tempvars (list (loop-make-variable
1410                                         (or (loop-collector-name lc)
1411                                             (loop-gentemp 'loop-sum-))
1412                                         nil (loop-collector-dtype lc)))))
1413            (unless (loop-collector-name lc)
1414              (loop-emit-final-value (car (loop-collector-tempvars lc)))))
1415          (loop-emit-body
1416            (if (eq specifically 'count)
1417                `(when ,form
1418                   (setq ,(car tempvars)
1419                         ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars)))))
1420                `(setq ,(car tempvars)
1421                       (+ ,(hide-variable-reference t (car tempvars) (car tempvars))
1422                          ,form)))))))
1423    
1424    
1425    
1426    (defun loop-maxmin-collection (specifically)
1427      (multiple-value-bind (lc form)
1428          (loop-get-collection-info specifically 'maxmin *loop-real-data-type*)
1429        (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*)
1430        (let ((data (loop-collector-data lc)))
1431          (unless data
1432            (setf (loop-collector-data lc)
1433                  (setq data (make-loop-minimax
1434                               (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-))
1435                               (loop-collector-dtype lc))))
1436            (unless (loop-collector-name lc)
1437              (loop-emit-final-value (loop-minimax-answer-variable data))))
1438          (loop-note-minimax-operation specifically data)
1439          (push `(with-minimax-value ,data) *loop-wrappers*)
1440          (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form))
1441          )))
1442    
1443    
1444    ;;;; Value Accumulation:  Aggregate Booleans
1445    
1446    ;;;ALWAYS and NEVER.
1447    ;;; Under ANSI these are not permitted to appear under conditionalization.
1448    (defun loop-do-always (restrictive negate)
1449      (let ((form (loop-get-form)))
1450        (when restrictive (loop-disallow-conditional))
1451        (loop-emit-body `(,(if negate 'when 'unless) ,form
1452                        ,(loop-construct-return nil)))                        ,(loop-construct-return nil)))
1453      (push (loop-construct-return t) *loop-after-epilogue*)))      (loop-emit-final-value t)))
1454    
1455  ;THEREIS expression  
1456  ;If expression evaluates non-nil, return that value.  
1457  (defun loop-do-thereis ()  ;;;THERIS.
1458     (loop-emit-body `(when (setq ,(loop-when-it-variable)  ;;; Under ANSI this is not permitted to appear under conditionalization.
1459                                  ,(loop-get-form 'thereis))  (defun loop-do-thereis (restrictive)
1460                        ,(loop-construct-return *loop-when-it-variable*))))    (when restrictive (loop-disallow-conditional))
1461      (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form))
1462                         ,(loop-construct-return *loop-when-it-variable*))))
1463  ;;;; Hacks  
1464    
1465  (defun loop-simplep (expr)  (defun loop-do-while (negate kwd &aux (form (loop-get-form)))
1466      (if (null expr) 0    (loop-disallow-conditional kwd)
1467        (catch 'loop-simplep    (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop))))
1468          (let ((ans (loop-simplep-1 expr)))  
1469            (declare (fixnum ans))  
1470            (and (< ans 20.) ans)))))  (defun loop-do-with ()
1471      (loop-disallow-conditional :with)
1472  (defvar loop-simplep    (do ((var) (val) (dtype)) (nil)
1473          '(> < <= >= /= + - 1+ 1- ash equal atom setq prog1 prog2 and or = aref char schar sbit svref))      (setq var (loop-pop-source)
1474              dtype (loop-optional-type var)
1475  (defun loop-simplep-1 (x)            val (cond ((loop-tequal (car *loop-source-code*) :=)
1476    (let ((z 0))                       (loop-pop-source)
1477      (declare (fixnum z))                       (loop-get-form))
1478      (cond ((loop-constantp x) 0)                      (t nil)))
1479            ((atom x) 1)      (loop-make-variable var val dtype)
1480            ((eq (car x) 'cond)      (if (loop-tequal (car *loop-source-code*) :and)
1481               (do ((cl (cdr x) (cdr cl))) ((null cl))          (loop-pop-source)
1482                 (do ((f (car cl) (cdr f))) ((null f))          (return (loop-bind-block)))))
                  (setq z (+ (loop-simplep-1 (car f)) z 1))))  
              z)  
           ((symbolp (car x))  
              (let ((fn (car x)) (tem nil))  
                (cond ((setq tem (get fn 'loop-simplep))  
                         (if (typep tem 'fixnum) (setq z tem)  
                             (setq z (funcall tem x) x nil)))  
                      ((member fn '(null not eq go return progn)))  
                      ((member fn '(car cdr)) (setq z 1))  
                      ((member fn '(caar cadr cdar cddr)) (setq z 2))  
                      ((member fn '(caaar caadr cadar caddr  
                                    cdaar cdadr cddar cdddr))  
                         (setq z 3))  
                      ((member fn '(caaaar caaadr caadar caaddr  
                                    cadaar cadadr caddar cadddr  
                                    cdaaar cdaadr cdadar cdaddr  
                                    cddaar cddadr cdddar cddddr))  
                         (setq z 4))  
                      ((member fn loop-simplep) (setq z 2))  
                      (t (multiple-value-bind (new-form expanded-p)  
                               (macroexpand-1 x *loop-macro-environment*)  
                           (if expanded-p  
                               (setq z (loop-simplep-1 new-form) x nil)  
                             (throw 'loop-simplep nil)))))  
                (do ((l (cdr x) (cdr l))) ((null l))  
                  (setq z (+ (loop-simplep-1 (car l)) 1 z)))  
                z))  
           (t (throw 'loop-simplep nil)))))  
1483    
1484    
1485  ;;;; The iteration driver  ;;;; The iteration driver
1486    
1487  (defun loop-hack-iteration (entry)  (defun loop-hack-iteration (entry)
1488    (do ((last-entry entry)    (flet ((make-endtest (list-of-forms)
1489         (source *loop-source-code* *loop-source-code*)             (cond ((null list-of-forms) nil)
1490         (pre-step-tests nil)                   ((member t list-of-forms) '(go end-loop))
1491         (steps nil)                   (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
1492         (post-step-tests nil)                                  (car list-of-forms)
1493         (pseudo-steps nil)                                  (cons 'or list-of-forms))
1494         (pre-loop-pre-step-tests nil)                         (go end-loop))))))
1495         (pre-loop-steps nil)      (do ((pre-step-tests nil)
1496         (pre-loop-post-step-tests nil)           (steps nil)
1497         (pre-loop-pseudo-steps nil)           (post-step-tests nil)
1498         (tem) (data) (foo) (bar))           (pseudo-steps nil)
1499        (nil)           (pre-loop-pre-step-tests nil)
1500      ; Note we collect endtests in reverse order, but steps in correct           (pre-loop-steps nil)
1501      ; order.  LOOP-END-TESTIFY does the nreverse for us.           (pre-loop-post-step-tests nil)
1502      (setq tem (setq data (apply (cadr entry) (cddr entry))))           (pre-loop-pseudo-steps nil)
1503      (and (car tem) (push (car tem) pre-step-tests))           (tem) (data))
1504      (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))          (nil)
1505      (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))        ;; Note we collect endtests in reverse order, but steps in correct
1506      (setq pseudo-steps        ;; order.  MAKE-ENDTEST does the nreverse for us.
1507            (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))        (setq tem (setq data (apply (symbol-function (first entry)) (rest entry))))
1508      (setq tem (cdr tem))        (and (car tem) (push (car tem) pre-step-tests))
1509      (and (or *loop-conditionals* *loop-emitted-body?*)        (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))
1510           (or tem pre-step-tests post-step-tests pseudo-steps)        (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
1511           (let ((cruft (list (car entry) (car source)        (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
1512                              (cadr source) (caddr source))))        (setq tem (cdr tem))
1513              (if *loop-emitted-body?*        (when *loop-emitted-body*
1514                  (loop-simple-error          (loop-error "Iteration in LOOP follows body code."))
1515                     "Iteration is not allowed to follow body code" cruft)        (unless tem (setq tem data))
1516                  (loop-simple-error        (when (car tem) (push (car tem) pre-loop-pre-step-tests))
1517                     "Iteration starting inside of conditional in LOOP"        (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
1518                     cruft))))        (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
1519      (or tem (setq tem data))        (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
1520      (and (car tem) (push (car tem) pre-loop-pre-step-tests))        (unless (loop-tequal (car *loop-source-code*) :and)
1521      (setq pre-loop-steps          (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps)
1522            (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))                                          (make-endtest pre-loop-post-step-tests)
1523      (and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))                                          (loop-make-psetq pre-loop-steps)
1524      (setq pre-loop-pseudo-steps                                          (make-endtest pre-loop-pre-step-tests)
1525            (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))                                          *loop-before-loop*)
1526      (cond ((or (not (loop-tequal (car *loop-source-code*) 'and))                *loop-after-body* (list* (loop-make-desetq pseudo-steps)
1527                 (and *loop-conditionals*                                         (make-endtest post-step-tests)
1528                      (not (loop-tassoc (cadr *loop-source-code*)                                         (loop-make-psetq steps)
1529                                           +loop-iteration-keyword-alist+))))                                         (make-endtest pre-step-tests)
1530               (setq foo (list (loop-end-testify pre-loop-pre-step-tests)                                         *loop-after-body*))
1531                               (loop-make-psetq pre-loop-steps)          (loop-bind-block)
1532                               (loop-end-testify pre-loop-post-step-tests)          (return nil))
1533                               (loop-make-setq pre-loop-pseudo-steps))        (loop-pop-source)                         ; flush the "AND"
1534                     bar (list (loop-end-testify pre-step-tests)        (when (and (not (loop-universe-implicit-for-required *loop-universe*))
1535                               (loop-make-psetq steps)                   (setq tem (loop-lookup-keyword
1536                               (loop-end-testify post-step-tests)                               (car *loop-source-code*)
1537                               (loop-make-setq pseudo-steps)))                               (loop-universe-iteration-keywords *loop-universe*))))
1538               (cond ((not *loop-conditionals*)          ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied.
1539                        (setq *loop-before-loop* (nreconc foo *loop-before-loop*)          (loop-pop-source)
1540                              *loop-after-body* (nreconc bar *loop-after-body*)))          (setq entry tem)))))
                    (t ((lambda (*loop-conditionals*)  
                           (push (loop-make-conditionalization  
                                    (cons 'progn (delete nil foo)))  
                                 *loop-before-loop*))  
                        (mapcar #'(lambda (x)    ;Copy parts that will get rplacd'ed  
                                    (cons (car x)  
                                          (mapcar #'(lambda (x) (loop-copylist* x)) (cdr x))))  
                                *loop-conditionals*))  
                       (push (loop-make-conditionalization  
                                (cons 'progn (delete nil bar)))  
                             *loop-after-body*)))  
              (loop-bind-block)  
              (return nil)))  
     (loop-pop-source) ; flush the "AND"  
     (setq entry (cond ((setq tem (loop-tassoc  
                                     (car *loop-source-code*)  
                                     +loop-iteration-keyword-alist+))  
                          (loop-pop-source)  
                          (setq last-entry tem))  
                       (t last-entry)))))  
1541    
1542    
1543    ;;;; Main Iteration Drivers
1544    
1545    
1546  ;FOR variable keyword ..args..  ;FOR variable keyword ..args..
1547  (defun loop-do-for ()  (defun loop-do-for ()
1548    (let ((var (loop-pop-source))    (let* ((var (loop-pop-source))
1549          (data-type? (loop-optional-type))           (data-type (loop-optional-type var))
1550          (keyword (loop-pop-source))           (keyword (loop-pop-source))
1551          (first-arg nil)           (first-arg nil)
1552          (tem nil))           (tem nil))
1553      (setq first-arg (loop-get-form (list 'for var keyword)))      (setq first-arg (loop-get-form))
1554      (or (setq tem (loop-tassoc keyword +loop-for-keyword-alist+))      (unless (and (symbolp keyword)
1555          (loop-simple-error                   (setq tem (loop-lookup-keyword
1556             "Unknown keyword in FOR or AS clause in LOOP"                               keyword
1557             (list 'for var keyword)))                               (loop-universe-for-keywords *loop-universe*))))
1558      (apply (cadr tem) var first-arg data-type? (cddr tem))))        (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword))
1559        (apply (car tem) var first-arg data-type (cdr tem))))
1560    
1561    
1562  (defun loop-do-repeat ()  (defun loop-do-repeat ()
1563      (let ((var (loop-make-variable    (let ((form (loop-get-form))
1564                    (loop-gentemp 'loop-repeat-)          (type (loop-check-data-type (loop-optional-type) *loop-real-data-type*)))
1565                    (loop-get-form 'repeat) 'fixnum)))      (when (and (consp form) (eq (car form) 'the) (subtypep (second form) type))
1566         `((not (,(loop-typed-arith 'plusp 'fixnum) ,var))        (setq type (second form)))
1567           () ()      (multiple-value-bind (number constantp value)
1568           (,var (,(loop-typed-arith '1- 'fixnum) ,var)))))          (loop-constant-fold-if-possible form type)
1569          (cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ()))
1570                (t (let ((var (loop-make-variable (loop-gentemp 'loop-repeat-) number type)))
1571                     (if constantp
1572                         `((not (plusp (setq ,var (1- ,var)))) () () () () () () ())
1573                         `((minusp (setq ,var (1- ,var))) () () ()))))))))
1574    
1575    
 ; Kludge the First  
1576  (defun loop-when-it-variable ()  (defun loop-when-it-variable ()
1577      (or *loop-when-it-variable*    (or *loop-when-it-variable*
1578          (setq *loop-when-it-variable*        (setq *loop-when-it-variable*
1579                (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))              (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
1580    
1581    
1582    ;;;; Various FOR/AS Subdispatches
1583  (defun loop-for-equals (var val data-type?)  
1584    (cond ((loop-tequal (car *loop-source-code*) 'then)  
1585             ;FOR var = first THEN next  ;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN
1586    ;;; is omitted (other than being more stringent in its placement), and like
1587    ;;; the old "FOR x FIRST y THEN z" when the THEN is present.  I.e., the first
1588    ;;; initialization occurs in the loop body (first-step), not in the variable binding
1589    ;;; phase.
1590    (defun loop-ansi-for-equals (var val data-type)
1591      (loop-make-iteration-variable var nil data-type)
1592      (cond ((loop-tequal (car *loop-source-code*) :then)
1593             ;;Then we are the same as "FOR x FIRST y THEN z".
1594             (loop-pop-source)
1595             `(() (,var ,(loop-get-form)) () ()
1596               () (,var ,val) () ()))
1597            (t ;;We are the same as "FOR x = y".
1598             `(() (,var ,val) () ()))))
1599    
1600    
1601    (defun loop-for-across (var val data-type)
1602      (loop-make-iteration-variable var nil data-type)
1603      (let ((vector-var (loop-gentemp 'loop-across-vector-))
1604            (index-var (loop-gentemp 'loop-across-index-)))
1605        (multiple-value-bind (vector-form constantp vector-value)
1606            (loop-constant-fold-if-possible val 'vector)
1607          (loop-make-variable
1608            vector-var vector-form
1609            (if (and (consp vector-form) (eq (car vector-form) 'the))
1610                (cadr vector-form)
1611                'vector))
1612          #+Genera (push `(system:array-register ,vector-var) *loop-declarations*)
1613          (loop-make-variable index-var 0 'fixnum)
1614          (let* ((length 0)
1615                 (length-form (cond ((not constantp)
1616                                     (let ((v (loop-gentemp 'loop-across-limit-)))
1617                                       (push `(setq ,v (length ,vector-var)) *loop-prologue*)
1618                                       (loop-make-variable v 0 'fixnum)))
1619                                    (t (setq length (length vector-value)))))
1620                 (first-test `(>= ,index-var ,length-form))
1621                 (other-test first-test)
1622                 (step `(,var (aref ,vector-var ,index-var)))
1623                 (pstep `(,index-var (1+ ,index-var))))
1624            (declare (fixnum length))
1625            (when constantp
1626              (setq first-test (= length 0))
1627              (when (<= length 1)
1628                (setq other-test t)))
1629            `(,other-test ,step () ,pstep
1630              ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep)))))))
1631    
1632    
1633    
1634    ;;;; List Iteration
1635    
1636    
1637    (defun loop-list-step (listvar)
1638      ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any
1639      ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used
1640      ;; as the stepping function.
1641      ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not
1642      ;; recognizing FOO may defeat some LOOP optimizations.
1643      (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by)
1644                            (loop-pop-source)
1645                            (loop-get-form))
1646                           (t '(function cdr)))))
1647        (cond ((and (consp stepper) (eq (car stepper) 'quote))
1648               (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.")
1649               (values `(funcall ,stepper ,listvar) nil))
1650              ((and (consp stepper) (eq (car stepper) 'function))
1651               (values (list (cadr stepper) listvar) (cadr stepper)))
1652              (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function)
1653                                   ,listvar)
1654                         nil)))))
1655    
1656    
1657    (defun loop-for-on (var val data-type)
1658      (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val)
1659        (let ((listvar var))
1660          (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type))
1661                (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list)
1662                   (loop-make-iteration-variable var nil data-type)))
1663          (multiple-value-bind (list-step step-function) (loop-list-step listvar)
1664            (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function))
1665            ;; The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind.
1666            (let* ((first-endtest
1667                    (hide-variable-reference
1668                     (eq var listvar)
1669                     listvar
1670                     ;; the following should use `atom' instead of `endp', per
1671                     ;; [bug2428]
1672                     `(atom ,listvar)))
1673                   (other-endtest first-endtest))
1674              (when (and constantp (listp list-value))
1675                (setq first-endtest (null list-value)))
1676              (cond ((eq var listvar)
1677                     ;;Contour of the loop is different because we use the user's variable...
1678                     `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest
1679                       () () () ,first-endtest ()))
1680                    #+LOOP-Prefer-POP
1681                    ((and step-function
1682                          (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2)
1683                                                               (cdddr . 3) (cddddr . 4))))))
1684                            (and n (do ((l var (cdr l)) (i 0 (1+ i)))
1685                                       ((atom l) (and (null l) (= i n)))
1686                                     (declare (fixnum i))))))
1687                     (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var)))
1688                       `(,other-endtest () () ,step ,first-endtest () () ,step)))
1689                    (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step)))
1690                         `(,other-endtest ,step () ,pseudo
1691                           ,@(and (not (eq first-endtest other-endtest))
1692                                  `(,first-endtest ,step () ,pseudo)))))))))))
1693    
1694    
1695    (defun loop-for-in (var val data-type)
1696      (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val)
1697        (let ((listvar (loop-gentemp 'loop-list-)))
1698          (loop-make-iteration-variable var nil data-type)
1699          (loop-make-variable listvar list 'list)
1700          (multiple-value-bind (list-step step-function) (loop-list-step listvar)
1701            #-LOOP-Prefer-POP (declare (ignore step-function))
1702            (let* ((first-endtest `(endp ,listvar))
1703                   (other-endtest first-endtest)
1704                   (step `(,var (car ,listvar)))
1705                   (pseudo-step `(,listvar ,list-step)))
1706              (when (and constantp (listp list-value))
1707                (setq first-endtest (null list-value)))
1708              #+LOOP-Prefer-POP (when (eq step-function 'cdr)
1709                                  (setq step `(,var (pop ,listvar)) pseudo-step nil))
1710              `(,other-endtest ,step () ,pseudo-step
1711                ,@(and (not (eq first-endtest other-endtest))
1712                       `(,first-endtest ,step () ,pseudo-step))))))))
1713    
1714    
1715    ;;;; Iteration Paths
1716    
1717    
1718    (defstruct (loop-path
1719                 #+ecls (:type vector)
1720                 #+nil (:copier nil)
1721                 #+nil (:predicate nil))
1722      names
1723      preposition-groups
1724      inclusive-permitted
1725      function
1726      user-data)
1727    
1728    
1729    (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data)
1730      (unless (listp names) (setq names (list names)))
1731      ;; Can't do this due to CLOS bootstrapping problems.
1732      #-(or Genera (and CLOE Source-Bootstrap) ecls) (check-type universe loop-universe)
1733      (let ((ht (loop-universe-path-keywords universe))
1734            (lp (make-loop-path
1735                  :names (mapcar #'symbol-name names)
1736                  :function function
1737                  :user-data user-data
1738                  :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups)
1739                  :inclusive-permitted inclusive-permitted)))
1740        (dolist (name names) (setf (gethash (symbol-name name) ht) lp))
1741        lp))
1742    
1743    
1744    ;;; Note:  path functions are allowed to use loop-make-variable, hack
1745    ;;; the prologue, etc.
1746    (defun loop-for-being (var val data-type)
1747      ;; FOR var BEING each/the pathname prep-phrases using-stuff...
1748      ;; each/the = EACH or THE.  Not clear if it is optional, so I guess we'll warn.
1749      (let ((path nil)
1750            (data nil)
1751            (inclusive nil)
1752            (stuff nil)
1753            (initial-prepositions nil))
1754        (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source)))
1755              ((loop-tequal (car *loop-source-code*) :and)
1756             (loop-pop-source)             (loop-pop-source)
1757             (loop-make-iteration-variable var val data-type?)             (setq inclusive t)
1758             `(() (,var ,(loop-get-form (list 'for var '= val 'then))) () ()             (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her))
1759               () () () ()))               (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax."
1760          (t (loop-make-iteration-variable var nil data-type?)                           (car *loop-source-code*)))
1761             (let ((varval (list var val)))             (loop-pop-source)
1762               (cond (*loop-emitted-body?*             (setq path (loop-pop-source))
1763                      (loop-emit-body (loop-make-setq varval))             (setq initial-prepositions `((:in ,val))))
1764                      '(() () () ()))            (t (loop-error "Unrecognizable LOOP iteration path syntax.  Missing EACH or THE?")))
1765                     (`(() ,varval () ())))))))      (cond ((not (symbolp path))
1766               (loop-error "~S found where a LOOP iteration path name was expected." path))
1767  (defun loop-for-first (var val data-type?)            ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*))))
1768      (or (loop-tequal (car *loop-source-code*) 'then)             (loop-error "~S is not the name of a LOOP iteration path." path))
1769          (loop-simple-error "found where THEN expected in FOR ... FIRST"            ((and inclusive (not (loop-path-inclusive-permitted data)))
1770                             (car *loop-source-code*)))             (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path)))
1771      (loop-pop-source)      (let ((fun (loop-path-function data))
1772      (loop-make-iteration-variable var nil data-type?)            (preps (nconc initial-prepositions
1773      `(() (,var ,(loop-get-form (list 'for var 'first val 'then))) () ()                          (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t)))
1774        () (,var ,val) () ()))            (user-data (loop-path-user-data data)))
1775          (when (symbolp fun) (setq fun (symbol-function fun)))
1776          (setq stuff (if inclusive
1777  (defun loop-list-stepper (var val data-type? fn)                        (apply fun var data-type preps :inclusive t user-data)
1778      (let ((stepper (cond ((loop-tequal (car *loop-source-code*) 'by)                        (apply fun var data-type preps user-data))))
1779                              (loop-pop-source)      (when *loop-named-variables*
1780                              (loop-get-form (list 'for var        (loop-error "Unused USING variables: ~S." *loop-named-variables*))
1781                                                   (if (eq fn 'car) 'in 'on)      ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back).  Protect the system from the user
1782                                                   val 'by)))      ;; and the user from himself.
1783                           (t '(function cdr))))      (unless (member (length stuff) '(6 10))
1784            (var1 nil) (stepvar nil) (step nil) (et nil) (pseudo nil))        (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
1785         (setq step (if (or (atom stepper)                    path))
1786                            (not (member (car stepper) '(quote function))))      (do ((l (car stuff) (cdr l)) (x)) ((null l))
1787                        `(funcall ,(setq stepvar (loop-gentemp 'loop-fn-)))        (if (atom (setq x (car l)))
1788                        (list (cadr stepper))))            (loop-make-iteration-variable x nil nil)
1789         (cond ((and (atom var)            (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
1790                     ;; (eq (car step) 'cdr)      (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*))
1791                     (not fn))      (cddr stuff)))
1792                  (setq var1 (loop-make-iteration-variable var val data-type?)))  
1793               (t (loop-make-iteration-variable var nil data-type?)  
1794                  (setq var1 (loop-make-variable  
1795                               (loop-gentemp 'loop-list-) val nil))  ;;;INTERFACE:  Lucid, exported.
1796                  (setq pseudo (list var (if fn (list fn var1) var1)))))  ;;; i.e., this is part of our extended ansi-loop interface.
1797         (rplacd (last step) (list var1))  (defun named-variable (name)
1798         (and stepvar (loop-make-variable stepvar stepper nil))    (let ((tem (loop-tassoc name *loop-named-variables*)))
1799         (setq stepper (list var1 step) et `(null ,var1))      (declare (list tem))
1800         (if (not pseudo) `(() ,stepper ,et () () () ,et ())      (cond ((null tem) (values (loop-gentemp) nil))
1801             (if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper)            (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
1802                 `((null (setq ,@stepper)) () () ,pseudo ,et () () ,pseudo)))))               (values (cdr tem) t)))))
1803    
1804    
1805  (defun loop-for-arithmetic (var val data-type? kwd)  (defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases)
1806    ; Args to loop-sequencer:    (flet ((in-group-p (x group) (car (loop-tmember x group))))
1807    ; indexv indexv-type variable? vtype? sequencev? sequence-type      (do ((token nil)
1808    ; stephack? default-top? crap prep-phrases           (prepositional-phrases initial-phrases)
1809    (loop-sequencer           (this-group nil nil)
1810       var (or data-type? 'fixnum) nil nil nil nil nil nil `(for ,var ,kwd ,val)           (this-prep nil nil)
1811       (cons (list kwd val)           (disallowed-prepositions
1812             (loop-gather-preps             (mapcan #'(lambda (x)
1813                '(from upfrom downfrom to upto downto above below by)                         (loop-copylist*
1814                nil))))                           (find (car x) preposition-groups :test #'in-group-p)))
1815                       initial-phrases))
1816             (used-prepositions (mapcar #'car initial-phrases)))
1817  (defun loop-named-variable (name)          ((null *loop-source-code*) (nreverse prepositional-phrases))
1818      (let ((tem (loop-tassoc name *loop-named-variables*)))        (declare (symbol this-prep))
1819         (cond ((null tem) (loop-gentemp))        (setq token (car *loop-source-code*))
1820               (t (setq *loop-named-variables* (delete tem *loop-named-variables*))        (dolist (group preposition-groups)
1821                  (cdr tem)))))          (when (setq this-prep (in-group-p token group))
1822              (return (setq this-group group))))
1823          (cond (this-group
1824  ; Note:  path functions are allowed to use loop-make-variable, hack               (when (member this-prep disallowed-prepositions)
1825  ; the prologue, etc.                 (loop-error
1826  (defun loop-for-being (var val data-type?)                   (if (member this-prep used-prepositions)
1827     ; FOR var BEING something ... - var = VAR, something = VAL.                       "A ~S prepositional phrase occurs multiply for some LOOP clause."
1828     ; If what passes syntactically for a pathname isn't, then                       "Preposition ~S used when some other preposition has subsumed it.")
1829     ; we trap to the DEFAULT-LOOP-PATH path;  the expression which looked like                   token))
1830     ; a path is given as an argument to the IN preposition.  Thus,               (setq used-prepositions (if (listp this-group)
1831     ; by default, FOR var BEING EACH expr OF expr-2                                           (append this-group used-prepositions)
1832     ; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2.                                           (cons this-group used-prepositions)))
1833     (let ((tem nil) (inclusive? nil) (ipps nil) (each? nil) (attachment nil))               (loop-pop-source)
1834       (if (or (loop-tequal val 'each) (loop-tequal val 'the))               (push (list this-prep (loop-get-form)) prepositional-phrases))
1835           (setq each? 't val (car *loop-source-code*))              ((and USING-allowed (loop-tequal token 'using))
1836           (push val *loop-source-code*))               (loop-pop-source)
1837       (cond ((and (setq tem (loop-tassoc val *loop-path-keyword-alist*))               (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
1838                   (or each? (not (loop-tequal (cadr *loop-source-code*)                 (when (or (atom z)
1839                                                  'and))))                           (atom (cdr z))
               ;; FOR var BEING {each} path {prep expr}..., but NOT  
               ;; FOR var BEING var-which-looks-like-path AND {ITS} ...  
               (loop-pop-source))  
            (t (setq val (loop-get-form (list 'for var 'being)))  
               (cond ((loop-tequal (car *loop-source-code*) 'and)  
                        ;; FOR var BEING value AND ITS path-or-ar  
                        (or (null each?)  
                            (loop-simple-error  
                               "Malformed BEING EACH clause in LOOP" var))  
                        (setq ipps `((of ,val)) inclusive? t)  
                        (loop-pop-source)  
                        (or (loop-tmember (setq tem (loop-pop-source))  
                                             '(its his her their each))  
                            (loop-simple-error  
                               "found where ITS or EACH expected in LOOP path"  
                               tem))  
                        (if (setq tem (loop-tassoc  
                                         (car *loop-source-code*)  
                                         *loop-path-keyword-alist*))  
                            (loop-pop-source)  
                            (push (setq attachment  
                                        `(in ,(loop-get-form  
                                               `(for ,var being \.\.\. in))))  
                                  ipps)))  
                     ((not (setq tem (loop-tassoc  
                                        (car *loop-source-code*)  
                                        *loop-path-keyword-alist*)))  
                        ; FOR var BEING {each} a-r ...  
                        (setq ipps (list (setq attachment (list 'in val)))))  
                     (t ; FOR var BEING {each} pathname ...  
                        ; Here, VAL should be just PATHNAME.  
                        (loop-pop-source)))))  
      (cond ((not (null tem)))  
            ((not (setq tem (loop-tassoc 'default-loop-path  
                                            *loop-path-keyword-alist*)))  
               (loop-simple-error "Undefined LOOP iteration path"  
                                  (cadr attachment))))  
      (setq tem (funcall (cadr tem) (car tem) var data-type?  
                         (nreconc ipps (loop-gather-preps (caddr tem) t))  
                         inclusive? (caddr tem) (cdddr tem)))  
      (and *loop-named-variables*  
           (loop-simple-error "unused USING variables" *loop-named-variables*))  
      ; For error continuability (if there is any):  
      (setq *loop-named-variables* nil)  
      ;; TEM is now (bindings prologue-forms . stuff-to-pass-back)  
      (do ((l (car tem) (cdr l)) (x)) ((null l))  
        (if (atom (setq x (car l)))  
            (loop-make-iteration-variable x nil nil)  
            (loop-make-iteration-variable (car x) (cadr x) (caddr x))))  
      (setq *loop-prologue* (nconc (reverse (cadr tem)) *loop-prologue*))  
      (cddr tem)))  
   
   
 (defun loop-gather-preps (preps-allowed crockp)  
    (do ((token (car *loop-source-code*) (car *loop-source-code*)) (preps nil))  
        (nil)  
      (cond ((loop-tmember token preps-allowed)  
               (push (list (loop-pop-source)  
                           (loop-get-form `(for \... being \... ,token)))  
                     preps))  
            ((loop-tequal token 'using)  
               (loop-pop-source)  
               (or crockp (loop-simple-error  
                             "USING used in illegal context"  
                             (list 'using (car *loop-source-code*))))  
               (do ((z (car *loop-source-code*) (car *loop-source-code*)) (tem))  
                   ((atom z))  
                 (and (or (atom (cdr z))  
1840                           (not (null (cddr z)))                           (not (null (cddr z)))
1841                           (not (symbolp (car z)))                           (not (symbolp (car z)))
1842                           (and (cadr z) (not (symbolp (cadr z)))))                           (and (cadr z) (not (symbolp (cadr z)))))
1843                       (loop-simple-error                   (loop-error "~S bad variable pair in path USING phrase." z))
1844                          "bad variable pair in path USING phrase" z))                 (when (cadr z)
1845                  (cond ((not (null (cadr z)))                   (if (setq tem (loop-tassoc (car z) *loop-named-variables*))
1846                           (and (setq tem (loop-tassoc                       (loop-error
1847                                             (car z) *loop-named-variables*))                         "The variable substitution for ~S occurs twice in a USING phrase,~@
1848                                (loop-simple-error                          with ~S and ~S."
1849                                   "Duplicated var substitition in USING phrase"                         (car z) (cadr z) (cadr tem))
1850                                   (list tem z)))                       (push (cons (car z) (cadr z)) *loop-named-variables*)))
1851                           (push (cons (car z) (cadr z)) *loop-named-variables*)))                 (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*)))
1852                  (loop-pop-source)))                   (return nil))))
1853             (t (return (nreverse preps))))))              (t (return (nreverse prepositional-phrases)))))))
1854    
1855  (defun loop-add-path (name data)  
1856      (setq *loop-path-keyword-alist*  ;;;; Master Sequencer Function
1857            (cons (cons name data)  
1858                  (delete (loop-tassoc name *loop-path-keyword-alist*)  
1859                          *loop-path-keyword-alist*  (defun loop-sequencer (indexv indexv-type indexv-user-specified-p
1860                          :test #'eq)))                            variable variable-type
1861      nil)                            sequence-variable sequence-type
1862                              step-hack default-top
1863                              prep-phrases)
1864  (defmacro define-loop-path (names &rest cruft)     (let ((endform nil)                          ;Form (constant or variable) with limit value.
1865    "(DEFINE-LOOP-PATH NAMES PATH-FUNCTION LIST-OF-ALLOWABLE-PREPOSITIONS           (sequencep nil)                        ;T if sequence arg has been provided.
1866  DATUM-1 DATUM-2 ...)           (testfn nil)                           ;endtest function
1867  Defines PATH-FUNCTION to be the handler for the path(s) NAMES, which may           (test nil)                             ;endtest form.
1868  be either a symbol or a list of symbols.  LIST-OF-ALLOWABLE-PREPOSITIONS           (stepby (1+ (or (loop-typed-init indexv-type) 0)))     ;Our increment.
1869  contains a list of prepositions allowed in NAMES. DATUM-i are optional;           (stepby-constantp t)
1870  they are passed on to PATH-FUNCTION as a list."           (step nil)                             ;step form.
1871    (setq names (if (atom names) (list names) names))           (dir nil)                              ;Direction of stepping: NIL, :UP, :DOWN.
1872    (let ((forms (mapcar #'(lambda (name) `(loop-add-path ',name ',cruft))           (inclusive-iteration nil)              ;T if include last index.
1873                         names)))           (start-given nil)                      ;T when prep phrase has specified start
1874      `(eval-when (eval load compile) ,@forms)))           (start-value nil)
1875             (start-constantp nil)
1876             (limit-given nil)                      ;T when prep phrase has specified end
1877  (defun loop-sequencer (indexv indexv-type           (limit-constantp nil)
1878                            variable? vtype?           (limit-value nil)
1879                            sequencev? sequence-type?           )
1880                            stephack? default-top?       (when variable (loop-make-iteration-variable variable nil variable-type))
                           crap prep-phrases)  
    (let ((endform nil) (sequencep nil) (test nil)  
          (step ; Gross me out!  
                (1+ (or (loop-typed-init indexv-type) 0)))  
          (dir nil) (inclusive-iteration? nil) (start-given? nil) (limit-given? nil))  
      (and variable? (loop-make-iteration-variable variable? nil vtype?))  
1881       (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))       (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
1882         (setq prep (caar l) form (cadar l))         (setq prep (caar l) form (cadar l))
1883         (cond ((loop-tmember prep '(of in))         (case prep
1884                  (and sequencep (loop-simple-error           ((:of :in)
1885                                    "Sequence duplicated in LOOP path"            (setq sequencep t)
1886                                    (list variable? (car l))))            (loop-make-variable sequence-variable form sequence-type))
1887                  (setq sequencep t)           ((:from :downfrom :upfrom)
1888                  (loop-make-variable sequencev? form sequence-type?))            (setq start-given t)
1889               ((loop-tmember prep '(from downfrom upfrom))            (cond ((eq prep :downfrom) (setq dir ':down))
1890                  (and start-given?                  ((eq prep :upfrom) (setq dir ':up)))
1891                       (loop-simple-error            (multiple-value-setq (form start-constantp start-value)
1892                          "Iteration start redundantly specified in LOOP sequencing"              (loop-constant-fold-if-possible form indexv-type))
1893                          (append crap l)))            (loop-make-iteration-variable indexv form indexv-type))
1894                  (setq start-given? t)           ((:upto :to :downto :above :below)
1895                  (cond ((loop-tequal prep 'downfrom) (setq dir 'down))            (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up)))
1896                        ((loop-tequal prep 'upfrom) (setq dir 'up)))                  ((loop-tequal prep :to) (setq inclusive-iteration t))
1897                  (loop-make-iteration-variable indexv form indexv-type))                  ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down)))
1898               ((cond ((loop-tequal prep 'upto)                  ((loop-tequal prep :above) (setq dir ':down))
1899                         (setq inclusive-iteration? (setq dir 'up)))                  ((loop-tequal prep :below) (setq dir ':up)))
1900                      ((loop-tequal prep 'to)            (setq limit-given t)
1901                         (setq inclusive-iteration? t))            (multiple-value-setq (form limit-constantp limit-value)
1902                      ((loop-tequal prep 'downto)              (loop-constant-fold-if-possible form indexv-type))
1903                         (setq inclusive-iteration? (setq dir 'down)))            (setq endform (if limit-constantp
1904                      ((loop-tequal prep 'above) (setq dir 'down))                              `',limit-value
1905                      ((loop-tequal prep 'below) (setq dir 'up)))                              (loop-make-variable
1906                  (and limit-given?                                (loop-gentemp 'loop-limit-) form indexv-type))))
1907                       (loop-simple-error           (:by
1908                         "Endtest redundantly specified in LOOP sequencing path"             (multiple-value-setq (form stepby-constantp stepby)
1909                         (append crap l)))               (loop-constant-fold-if-possible form indexv-type))
1910                  (setq limit-given? t)             (unless stepby-constantp
1911                  (setq endform (loop-maybe-bind-form form indexv-type)))               (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type)))
1912               ((loop-tequal prep 'by)           (t (loop-error
1913                  (setq step (if (loop-constantp form) form                "~S invalid preposition in sequencing or sequence path.~@
1914                                 (loop-make-variable                 Invalid prepositions specified in iteration path descriptor or something?"
1915                                   (loop-gentemp 'loop-step-by-)                prep)))
1916                                   form 'fixnum))))         (when (and odir dir (not (eq dir odir)))
1917               (t ; This is a fatal internal error...           (loop-error "Conflicting stepping directions in LOOP sequencing path"))
                 (loop-simple-error "Illegal prep in sequence path"  
                                    (append crap l))))  
        (and odir dir (not (eq dir odir))  
             (loop-simple-error  
                "Conflicting stepping directions in LOOP sequencing path"  
                (append crap l)))  
1918         (setq odir dir))         (setq odir dir))
1919       (and sequencev? (not sequencep)       (when (and sequence-variable (not sequencep))
1920            (loop-simple-error "Missing OF phrase in sequence path" crap))         (loop-error "Missing OF or IN phrase in sequence path"))
1921       ; Now fill in the defaults.       ;; Now fill in the defaults.
1922       (setq step (list indexv step))       (unless start-given
1923       (cond ((member dir '(nil up))         (loop-make-iteration-variable
1924                (or start-given?           indexv
1925                    (loop-make-iteration-variable indexv 0 indexv-type))           (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0))
1926                (and (or limit-given?           indexv-type))
1927                         (cond (default-top?       (cond ((member dir '(nil :up))
1928                                  (loop-make-variable              (when (or limit-given default-top)
1929                                    (setq endform (loop-gentemp                (unless limit-given
1930                                                    'loop-seq-limit-))                  (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-))
1931                                    nil indexv-type)                                      nil indexv-type)
1932                                  (push `(setq ,endform ,default-top?)                  (push `(setq ,endform ,default-top) *loop-prologue*))
1933                                        *loop-prologue*))))                (setq testfn (if inclusive-iteration '> '>=)))
1934                     (setq test (if inclusive-iteration? '(> . args)              (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
1935                                    '(>= . args))))             (t (unless start-given
1936                (push '+ step))                  (unless default-top
1937             (t (cond ((not start-given?)                    (loop-error "Don't know where to start stepping."))
1938                         (or default-top?                  (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
1939                             (loop-simple-error                (when (and default-top (not endform))
1940                                "Don't know where to start stepping"                  (setq endform (loop-typed-init indexv-type) inclusive-iteration t))
1941                                (append crap prep-phrases)))                (when endform (setq testfn (if inclusive-iteration  '< '<=)))
1942                         (loop-make-iteration-variable indexv 0 indexv-type)                (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
1943                         (push `(setq ,indexv       (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform))))
1944                                      (,(loop-typed-arith '1- indexv-type)       (when step-hack
1945                                       ,default-top?))         (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack))))
1946                               *loop-prologue*)))       (let ((first-test test) (remaining-tests test))
1947                (cond ((and default-top? (not endform))         (when (and stepby-constantp start-constantp limit-constantp)
1948                         (setq endform (loop-typed-init indexv-type)           (when (setq first-test (funcall (symbol-function testfn) start-value limit-value))
1949                               inclusive-iteration? t)))             (setq remaining-tests t)))
1950                (and (not (null endform))         `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack
1951                     (setq test (if inclusive-iteration? '(< . args)           () () ,first-test ,step-hack))))
1952                                    '(<= . args))))  
1953                (push '- step)))  
1954       (and (and (numberp (caddr step)) (= (caddr step) 1))       ;Generic arith  ;;;; Interfaces to the Master Sequencer
1955            (rplacd (cdr (rplaca step (if (eq (car step) '+) '1+ '1-)))  
1956                    nil))  
1957       (rplaca step (loop-typed-arith (car step) indexv-type))  
1958       (setq step (list indexv step))  (defun loop-for-arithmetic (var val data-type kwd)
1959       (setq test (loop-typed-arith test indexv-type))    (loop-sequencer
1960       (setq test (subst (list indexv endform) 'args test))      var (loop-check-data-type data-type *loop-real-data-type*) t
1961       (and stephack? (setq stephack? `(,variable? ,stephack?)))      nil nil nil nil nil nil
1962       `(() ,step ,test ,stephack?      (loop-collect-prepositional-phrases
1963         () () ,test ,stephack?)))        '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
1964          nil (list (list kwd val)))))
1965    
1966  (defun loop-sequence-elements-path (path variable data-type  
1967                                         prep-phrases inclusive?  (defun loop-sequence-elements-path (variable data-type prep-phrases
1968                                         allowed-preps data)                                      &key fetch-function size-function sequence-type element-type)
1969      allowed-preps ; unused    (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index)
1970      (let ((indexv (loop-named-variable 'index))      (let ((sequencev (named-variable 'sequence)))
1971            (sequencev (loop-named-variable 'sequence))        #+Genera (when (and sequencev
1972            (fetchfun nil) (sizefun nil) (type nil) (default-var-type nil)                            (symbolp sequencev)
1973            (crap `(for ,variable being the ,path)))                            sequence-type
1974         (cond ((not (null inclusive?))                            (subtypep sequence-type 'vector)
1975                  (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path))                            (not (member (the symbol sequencev) *loop-nodeclare*)))
1976                  (loop-simple-error "Can't step sequence inclusively" crap)))                   (push `(sys:array-register ,sequencev) *loop-declarations*))
1977         (setq fetchfun (car data)        (list* nil nil                            ; dummy bindings and prologue
1978               sizefun (car (setq data (cdr data)))               (loop-sequencer
1979               type (car (setq data (cdr data)))                 indexv 'fixnum indexv-user-specified-p
1980               default-var-type (cadr data))                 variable (or data-type element-type)
1981         (list* nil nil ; dummy bindings and prologue                 sequencev sequence-type
1982                (loop-sequencer                 `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev)
1983                   indexv 'fixnum                 prep-phrases)))))
1984                   variable (or data-type default-var-type)  
1985                   sequencev type  
1986                   `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev)  ;;;; Builtin LOOP Iteration Paths
1987                   crap prep-phrases))))  
1988    
1989    #||
1990    (loop for v being the hash-values of ht do (print v))
1991  (defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun  (loop for k being the hash-keys of ht do (print k))
1992                                       &optional sequence-type element-type)  (loop for v being the hash-values of ht using (hash-key k) do (print (list k v)))
1993    "Defines a sequence iiteration path.  PATH-NAME-OR-NAMES is either an  (loop for k being the hash-keys of ht using (hash-value v) do (print (list k v)))
1994  atomic path name or a list of path names.  FETCHFUN is a function of  ||#
1995  two arguments, the sequence and the index of the item to be fetched.  
1996  Indexing is assumed to be zero-origined.  SIZEFUN is a function of  (defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which)
1997  one argument, the sequence; it should return the number of elements in    (check-type which (member hash-key hash-value))
1998  the sequence.  SEQUENCE-TYPE is the name of the data-type of the    (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
1999  sequence, and ELEMENT-TYPE is the name of the data-type of the elements           (loop-error "Too many prepositions!"))
2000  of the sequence."          ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path.")))
2001      `(define-loop-path ,path-name-or-names    (let ((ht-var (loop-gentemp 'loop-hashtab-))
2002          loop-sequence-elements-path          (next-fn (loop-gentemp 'loop-hashtab-next-))
2003          (of in from downfrom to downto below above by)          (dummy-predicate-var nil)
2004          ,fetchfun ,sizefun ,sequence-type ,element-type))          (post-steps nil))
2005        (multiple-value-bind (other-var other-p)
2006            (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
2007  ;;;; Setup stuff        ;; named-variable returns a second value of T if the name was actually
2008          ;; specified, so clever code can throw away the gensym'ed up variable if
2009          ;; it isn't really needed.
2010  (mapc #'(lambda (x)        ;;The following is for those implementations in which we cannot put dummy NILs
2011            (mapc #'(lambda (y)        ;; into multiple-value-setq variable lists.
2012                      (setq *loop-path-keyword-alist*        #-Genera (setq other-p t
2013                            (cons `(,y loop-sequence-elements-path                       dummy-predicate-var (loop-when-it-variable))
2014                                    (of in from downfrom to downto        (let ((key-var nil)
2015                                        below above by)              (val-var nil)
2016                                    ,@(cdr x))              (bindings `((,variable nil ,data-type)
2017                                  (delete (loop-tassoc                          (,ht-var ,(cadar prep-phrases))
2018                                            y *loop-path-keyword-alist*)                          ,@(and other-p other-var `((,other-var nil))))))
2019                                          *loop-path-keyword-alist*          (if (eq which 'hash-key)
2020                                          :test #'eq :count 1))))              (setq key-var variable val-var (and other-p other-var))
2021                  (car x)))              (setq key-var (and other-p other-var) val-var variable))
2022        '( ((element elements) elt length sequence)          (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
2023          ;The following should be done by using ELEMENTS and type dcls...          (when (consp key-var)
2024            ((vector-element            (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-))
2025              vector-elements                               ,@post-steps))
2026              array-element    ;; Backwards compatibility -- DRM            (push `(,key-var nil) bindings))
2027              array-elements)          (when (consp val-var)
2028             aref length vector)            (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-))
2029            ((simple-vector-element simple-vector-elements                               ,@post-steps))
2030              simple-general-vector-element simple-general-vector-elements)            (push `(,val-var nil) bindings))
2031             svref simple-vector-length simple-vector)          `(,bindings                             ;bindings
2032            ((bits bit bit-vector-element bit-vector-elements)            ()                                    ;prologue
2033               bit bit-vector-length bit-vector bit)            ()                                    ;pre-test
2034            ((simple-bit-vector-element simple-bit-vector-elements)            ()                                    ;parallel steps
2035               sbit simple-bit-vector-length simple-bit-vector bit)            (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) (,next-fn)))       ;post-test
2036            ((character characters string-element string-elements)            ,post-steps)))))
2037             char string-length string base-char)  
2038            ((simple-string-element simple-string-elements)  
2039             schar simple-string-length simple-string base-char)  (defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types)
2040          )    (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
2041        )           (loop-error "Too many prepositions!"))
2042            ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path.")))
2043      (unless (symbolp variable)
2044        (loop-error "Destructuring is not valid for package symbol iteration."))
2045      (let ((pkg-var (loop-gentemp 'loop-pkgsym-))
2046            (next-fn (loop-gentemp 'loop-pkgsym-next-)))
2047        (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*)
2048        `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases)))
2049          ()
2050          ()
2051          ()
2052          (not (multiple-value-setq (,(progn
2053                                        ;; If an implementation can get away without actually
2054                                        ;; using a variable here, so much the better.
2055                                        #+Genera NIL
2056                                        #-Genera (loop-when-it-variable))
2057                                     ,variable)
2058                 (,next-fn)))
2059          ())))
2060    
2061    ;;;; ANSI Loop
2062    
2063    (defun make-ansi-loop-universe (extended-p)
2064      (let ((w (make-standard-loop-universe
2065                 :keywords `((named (loop-do-named))
2066                             (initially (loop-do-initially))
2067                             (finally (loop-do-finally))
2068                             (do (loop-do-do))
2069                             (doing (loop-do-do))
2070                             (return (loop-do-return))
2071                             (collect (loop-list-collection list))
2072                             (collecting (loop-list-collection list))
2073                             (append (loop-list-collection append))
2074                             (appending (loop-list-collection append))
2075                             (nconc (loop-list-collection nconc))
2076                             (nconcing (loop-list-collection nconc))
2077                             (count (loop-sum-collection count ,*loop-real-data-type* fixnum))
2078                             (counting (loop-sum-collection count ,*loop-real-data-type* fixnum))
2079                             (sum (loop-sum-collection sum number number))
2080                             (summing (loop-sum-collection sum number number))
2081                             (maximize (loop-maxmin-collection max))
2082                             (minimize (loop-maxmin-collection min))
2083                             (maximizing (loop-maxmin-collection max))
2084                             (minimizing (loop-maxmin-collection min))
2085                             (always (loop-do-always t nil))        ; Normal, do always
2086                             (never (loop-do-always t t))   ; Negate the test on always.
2087                             (thereis (loop-do-thereis t))
2088                             (while (loop-do-while nil :while))     ; Normal, do while
2089                             (until (loop-do-while t :until))       ; Negate the test on while
2090                             (when (loop-do-if when nil))   ; Normal, do when
2091                             (if (loop-do-if if nil))       ; synonymous
2092                             (unless (loop-do-if unless t)) ; Negate the test on when
2093                             (with (loop-do-with)))
2094                 :for-keywords '((= (loop-ansi-for-equals))
2095                                 (across (loop-for-across))
2096                                 (in (loop-for-in))
2097                                 (on (loop-for-on))
2098                                 (from (loop-for-arithmetic :from))
2099                                 (downfrom (loop-for-arithmetic :downfrom))
2100                                 (upfrom (loop-for-arithmetic :upfrom))
2101                                 (below (loop-for-arithmetic :below))
2102                                 (to (loop-for-arithmetic :to))
2103                                 (upto (loop-for-arithmetic :upto))
2104                                 (being (loop-for-being)))
2105                 :iteration-keywords '((for (loop-do-for))
2106                                       (as (loop-do-for))
2107                                       (repeat (loop-do-repeat)))
2108                 :type-symbols '(array atom bignum bit bit-vector character compiled-function
2109                                       complex cons double-float fixnum float
2110                                       function hash-table integer keyword list long-float
2111                                       nil null number package pathname random-state
2112                                       ratio rational readtable sequence short-float
2113                                       simple-array simple-bit-vector simple-string
2114                                       simple-vector single-float standard-char
2115                                       stream string base-char
2116                                       symbol t vector)
2117                 :type-keywords nil
2118                 :ansi (if extended-p :extended t))))
2119        (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
2120                       :preposition-groups '((:of :in))
2121                       :inclusive-permitted nil
2122                       :user-data '(:which hash-key))
2123        (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
2124                       :preposition-groups '((:of :in))
2125                       :inclusive-permitted nil
2126                       :user-data '(:which hash-value))
2127        (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
2128                       :preposition-groups '((:of :in))
2129                       :inclusive-permitted nil
2130                       :user-data '(:symbol-types (:internal :external :inherited)))
2131        (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w
2132                       :preposition-groups '((:of :in))
2133                       :inclusive-permitted nil
2134                       :user-data '(:symbol-types (:external)))
2135        (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w
2136                       :preposition-groups '((:of :in))
2137                       :inclusive-permitted nil
2138                       :user-data '(:symbol-types (:internal)))
2139        w))
2140    
2141    
2142    (defparameter *loop-ansi-universe*
2143                  (make-ansi-loop-universe nil))
2144    
2145    
2146    (defun loop-standard-expansion (keywords-and-forms environment universe)
2147      (if (and keywords-and-forms (symbolp (car keywords-and-forms)))
2148          (loop-translate keywords-and-forms environment universe)
2149          (let ((tag (gensym)))
2150            `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
2151    
2152    
2153    ;;;INTERFACE: ANSI
2154    (defmacro loop (&environment env &rest keywords-and-forms)
2155      #+Genera (declare (compiler:do-not-record-macroexpansions)
2156                        (zwei:indentation . zwei:indent-loop))
2157      (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
2158    
2159    #+allegro
2160    (defun excl::complex-loop-expander (body env)
2161      (loop-standard-expansion body env *loop-ansi-universe*))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26