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

Last change on this file since 2327 was 2327, checked in by bryan, 14 years ago

remove all reader-conditionalized code for non-openmcl platforms.

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