source: trunk/ccl/library/loop.lisp @ 929

Last change on this file since 929 was 929, checked in by bryan, 16 years ago

add docstrings to the majority of common-lisp-user symbols starting
with a snapshot of those found in SBCL 0.8.18.

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