source: branches/qres/ccl/library/loop.lisp @ 15278

Last change on this file since 15278 was 12408, checked in by gz, 10 years ago

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods.

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 79.4 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                              (ccl::setf-function-name-p  (cadr x)))
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(pushnew '(loop-error . 0) ccl::*format-arg-functions* :test #'equal)
864(pushnew '(loop-warn . 0) ccl::*format-arg-functions* :test #'equal)
865
866
867(defun loop-check-data-type (specified-type required-type
868                             &optional (default-type required-type))
869  (if (null specified-type)
870      default-type
871      (multiple-value-bind (a b) (subtypep specified-type required-type)
872        (cond ((not b)
873               (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S."
874                          specified-type required-type))
875              ((not a)
876               (loop-error "Specified data type ~S is not a subtype of ~S."
877                           specified-type required-type)))
878        specified-type)))
879
880
881;;;INTERFACE: Traditional, ANSI, Lucid.
882(defmacro loop-finish ()
883  "Cause the iteration to terminate \"normally\", the same as implicit
884termination by an iteration driving clause, or by use of WHILE or
885UNTIL -- the epilogue code (if any) will be run, and any implicitly
886collected result will be returned as the value of the LOOP."
887  '(go end-loop))
888
889
890
891(defun subst-gensyms-for-nil (tree)
892  (declare (special *ignores*))
893  (cond
894    ((null tree) (car (push (loop-gentemp) *ignores*)))
895    ((atom tree) tree)
896    (t (cons (subst-gensyms-for-nil (car tree))
897             (subst-gensyms-for-nil (cdr tree))))))
898 
899(defun loop-build-destructuring-bindings (crocks forms)
900  (if crocks
901      (let ((*ignores* ()))
902        (declare (special *ignores*))
903        `((destructuring-bind ,(subst-gensyms-for-nil (car crocks))
904              ,(cadr crocks)
905            (declare (ignore ,@*ignores*))
906            ,@(loop-build-destructuring-bindings (cddr crocks) forms))))
907      forms))
908
909(defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*)
910  (let ((*loop-original-source-code* *loop-source-code*)
911        (*loop-source-context* nil)
912        (*loop-iteration-variables* nil)
913        (*loop-variables* nil)
914        (*loop-nodeclare* nil)
915        (*loop-named-variables* nil)
916        (*loop-declarations* nil)
917        (*loop-desetq-crocks* nil)
918        (*loop-bind-stack* nil)
919        (*loop-prologue* nil)
920        (*loop-wrappers* nil)
921        (*loop-before-loop* nil)
922        (*loop-body* nil)
923        (*loop-emitted-body* nil)
924        (*loop-after-body* nil)
925        (*loop-epilogue* nil)
926        (*loop-after-epilogue* nil)
927        (*loop-final-value-culprit* nil)
928        (*loop-inside-conditional* nil)
929        (*loop-when-it-variable* nil)
930        (*loop-never-stepped-variable* nil)
931        (*loop-names* nil)
932        (*loop-collection-cruft* nil))
933    (loop-iteration-driver)
934    (loop-bind-block)
935    (let ((answer `(loop-body
936                     ,(nreverse *loop-prologue*)
937                     ,(nreverse *loop-before-loop*)
938                     ,(nreverse *loop-body*)
939                     ,(nreverse *loop-after-body*)
940                     ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))
941      (dolist (entry *loop-bind-stack*)
942        (let ((vars (first entry))
943              (dcls (second entry))
944              (crocks (third entry))
945              (wrappers (fourth entry)))
946          (dolist (w wrappers)
947            (setq answer (append w (list answer))))
948          (when (or vars dcls crocks)
949            (let ((forms (list answer)))
950              ;;(when crocks (push crocks forms))
951              (when dcls (push `(declare ,@dcls) forms))
952              (setq answer `(,(cond ((not vars) 'locally)
953                                    (*loop-destructuring-hooks* (first *loop-destructuring-hooks*))
954                                    (t 'let))
955                             ,vars
956                             ,@(loop-build-destructuring-bindings crocks forms)))))))
957      (if *loop-names*
958          (do () ((null (car *loop-names*)) answer)
959            (setq answer `(block ,(pop *loop-names*) ,answer)))
960          `(block nil ,answer)))))
961
962
963(defun loop-iteration-driver ()
964  (do () ((null *loop-source-code*))
965    (let ((keyword (car *loop-source-code*)) (tem nil))
966      (cond ((not (symbolp keyword))
967             (loop-error "~S found where LOOP keyword expected." keyword))
968            (t (setq *loop-source-context* *loop-source-code*)
969               (loop-pop-source)
970               (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*)))
971                      ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.)
972                      (apply (symbol-function (first tem)) (rest tem)))
973                     ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*)))
974                      (loop-hack-iteration tem))
975                     ((loop-tmember keyword '(and else))
976                      ;; Alternative is to ignore it, ie let it go around to the next keyword...
977                      (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
978                                  keyword (car *loop-source-code*) (cadr *loop-source-code*)))
979                     (t (loop-error "~S is an unknown keyword in LOOP macro." keyword))))))))
980
981
982
983(defun loop-pop-source ()
984  (if *loop-source-code*
985      (pop *loop-source-code*)
986      (loop-error "LOOP source code ran out when another token was expected.")))
987
988
989(defun loop-get-compound-form ()
990  (let ((form (loop-get-form)))
991    (unless (consp form)
992      (loop-error "Compound form expected, but found ~A." form))
993    form))
994
995(defun loop-get-progn ()
996  (do ((forms (list (loop-get-compound-form))
997              (cons (loop-get-compound-form) forms))
998       (nextform (car *loop-source-code*)
999                 (car *loop-source-code*)))
1000      ((atom nextform)
1001       (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms))))))
1002
1003
1004(defun loop-get-form ()
1005  (if *loop-source-code*
1006      (loop-pop-source)
1007      (loop-error "LOOP code ran out where a form was expected.")))
1008
1009
1010(defun loop-construct-return (form)
1011  `(return-from ,(car *loop-names*) ,form))
1012
1013
1014(defun loop-pseudo-body (form)
1015  (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*))
1016        (t (push form *loop-before-loop*) (push form *loop-after-body*))))
1017
1018(defun loop-emit-body (form)
1019  (setq *loop-emitted-body* t)
1020  (loop-pseudo-body form))
1021
1022(defun loop-emit-final-value (&optional (form nil form-supplied-p))
1023  (when form-supplied-p
1024    (push (loop-construct-return form) *loop-after-epilogue*))
1025  (when *loop-final-value-culprit*
1026    (loop-warn "LOOP clause is providing a value for the iteration,~@
1027                however one was already established by a ~S clause."
1028               *loop-final-value-culprit*))
1029  (setq *loop-final-value-culprit* (car *loop-source-context*)))
1030
1031
1032(defun loop-disallow-conditional (&optional kwd)
1033  (when *loop-inside-conditional*
1034    (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd)))
1035
1036(defun loop-disallow-anonymous-collectors ()
1037  (when (find-if-not 'loop-collector-name *loop-collection-cruft*)
1038    (loop-error "This LOOP clause is not permitted with anonymous collectors.")))
1039
1040(defun loop-disallow-aggregate-booleans ()
1041  (when (loop-tmember *loop-final-value-culprit* '(always never thereis))
1042    (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans.")))
1043
1044
1045
1046;;;; Loop Types
1047
1048
1049(defun loop-typed-init (data-type)
1050  (when data-type
1051    (let ((val (if (subtypep data-type 'number)
1052                 (if (or (subtypep data-type 'float) (subtypep data-type '(complex float)))
1053                   (coerce 0 data-type)
1054                   0)
1055                 (if (subtypep data-type 'character)
1056                   #\Null
1057                   nil))))
1058      (and val (typep val data-type) val))))
1059
1060
1061(defun loop-optional-type (&optional variable)
1062  ;;No variable specified implies that no destructuring is permissible.
1063  (and *loop-source-code*                       ;Don't get confused by NILs...
1064       (let ((z (car *loop-source-code*)))
1065         (cond ((loop-tequal z 'of-type)
1066                ;;This is the syntactically unambigous form in that the form of the
1067                ;; type specifier does not matter.  Also, it is assumed that the
1068                ;; type specifier is unambiguously, and without need of translation,
1069                ;; a common lisp type specifier or pattern (matching the variable) thereof.
1070                (loop-pop-source)
1071                (loop-pop-source))
1072                     
1073               ((symbolp z)
1074                ;;This is the (sort of) "old" syntax, even though we didn't used to support all of
1075                ;; these type symbols.
1076                (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*))
1077                                     (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*)))))
1078                  (when type-spec
1079                    (loop-pop-source)
1080                    type-spec)))
1081               (t 
1082                ;;This is our sort-of old syntax.  But this is only valid for when we are destructuring,
1083                ;; so we will be compulsive (should we really be?) and require that we in fact be
1084                ;; doing variable destructuring here.  We must translate the old keyword pattern typespec
1085                ;; into a fully-specified pattern of real type specifiers here.
1086                (if (consp variable)
1087                    (unless (consp z)
1088                     (loop-error
1089                        "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected."
1090                        z))
1091                    (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z))
1092                (loop-pop-source)
1093                (labels ((translate (k v)
1094                           (cond ((null k) nil)
1095                                 ((atom k)
1096                                  (replicate
1097                                    (or (gethash k (loop-universe-type-symbols *loop-universe*))
1098                                        (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*))
1099                                        (loop-error
1100                                          "Destructuring type pattern ~S contains unrecognized type keyword ~S."
1101                                          z k))
1102                                    v))
1103                                 ((atom v)
1104                                  (loop-error
1105                                    "Destructuring type pattern ~S doesn't match variable pattern ~S."
1106                                    z variable))
1107                                 (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v))))))
1108                         (replicate (typ v)
1109                           (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v))))))
1110                  (translate z variable)))))))
1111
1112
1113
1114;;;; Loop Variables
1115
1116
1117(defun loop-bind-block ()
1118  (when (or *loop-variables* *loop-declarations* *loop-wrappers*)
1119    (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*)
1120          *loop-bind-stack*)
1121    (setq *loop-variables* nil
1122          *loop-declarations* nil
1123          *loop-desetq-crocks* nil
1124          *loop-wrappers* nil)))
1125
1126(defun loop-variable-p (name)
1127  (do ((entry *loop-bind-stack* (cdr entry))) (nil)
1128    (cond ((null entry)
1129           (return nil))
1130          ((assoc name (caar entry) :test #'eq)
1131           (return t)))))
1132
1133(defun loop-make-variable (name initialization dtype &optional iteration-variable-p)
1134  (cond ((null name)
1135         (cond ((not (null initialization))
1136                (push (list (setq name (loop-gentemp 'loop-ignore-))
1137                            initialization)
1138                      *loop-variables*)
1139                (push `(ignore ,name) *loop-declarations*))))
1140        ((atom name)
1141         (cond (iteration-variable-p
1142                (if (member name *loop-iteration-variables*)
1143                    (loop-error "Duplicated LOOP iteration variable ~S." name)
1144                    (push name *loop-iteration-variables*)))
1145               ((assoc name *loop-variables*)
1146                (loop-error "Duplicated variable ~S in LOOP parallel binding." name)))
1147         (unless (symbolp name)
1148           (loop-error "Bad variable ~S somewhere in LOOP." name))
1149         (unless initialization (setq initialization (loop-typed-init dtype)))
1150         (when (and dtype
1151                    (null initialization)
1152                    (not (typep nil dtype)))
1153           (if (eq dtype 'complex)
1154             (setq initialization 0 dtype 'number)
1155             (when iteration-variable-p
1156               (setq dtype `(or null ,dtype)))))
1157         (loop-declare-variable name dtype)
1158         ;; We use ASSOC on this list to check for duplications (above),
1159         ;; so don't optimize out this list:
1160         (push (list name initialization) *loop-variables*))
1161        (initialization
1162         (cond (*loop-destructuring-hooks*
1163                (loop-declare-variable name dtype)
1164                (push (list name initialization) *loop-variables*))
1165               (t (let ((newvar (loop-gentemp 'loop-destructure-)))
1166                    (loop-declare-variable name dtype)
1167                    (push (list newvar initialization) *loop-variables*)
1168                    ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
1169                    (setq *loop-desetq-crocks*
1170                      (list* name newvar *loop-desetq-crocks*))))))
1171        (t (let ((tcar nil) (tcdr nil))
1172             (if (atom dtype) (setq tcar (setq tcdr dtype))
1173                 (setq tcar (car dtype) tcdr (cdr dtype)))
1174             (loop-make-variable (car name) nil tcar iteration-variable-p)
1175             (loop-make-variable (cdr name) nil tcdr iteration-variable-p))))
1176  name)
1177
1178
1179(defun loop-make-iteration-variable (name initialization dtype)
1180  (loop-make-variable name initialization dtype t))
1181
1182
1183(defun loop-declare-variable (name dtype)
1184  (cond ((or (null name) (null dtype) (eq dtype t)) nil)
1185        ((symbolp name)
1186         (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
1187           (push `(type ,dtype ,name) *loop-declarations*)))
1188        ((consp name)
1189         (cond ((consp dtype)
1190                (loop-declare-variable (car name) (car dtype))
1191                (loop-declare-variable (cdr name) (cdr dtype)))
1192               (t (loop-declare-variable (car name) dtype)
1193                  (loop-declare-variable (cdr name) dtype))))
1194        (t (loop-error "Invalid LOOP variable passed in: ~S." name))))
1195
1196
1197(defun loop-maybe-bind-form (form data-type)
1198  (if (loop-constantp form)
1199      form
1200      (loop-make-variable (loop-gentemp 'loop-bind-) form data-type)))
1201
1202
1203
1204(defun loop-do-if (for negatep)
1205  (let ((form (loop-get-form))
1206        (*loop-inside-conditional* t)
1207        (it-p nil)
1208        (first-clause-p t))
1209    (flet ((get-clause (for)
1210             (do ((body nil)) (nil)
1211               (let ((key (car *loop-source-code*)) (*loop-body* nil) data)
1212                 (cond ((not (symbolp key))
1213                        (loop-error
1214                          "~S found where keyword expected getting LOOP clause after ~S."
1215                          key for))
1216                       (t (setq *loop-source-context* *loop-source-code*)
1217                          (loop-pop-source)
1218                          (when (and (loop-tequal (car *loop-source-code*) 'it)
1219                                     first-clause-p)
1220                            (setq *loop-source-code*
1221                                  (cons (or it-p (setq it-p (loop-when-it-variable)))
1222                                        (cdr *loop-source-code*))))
1223                          (cond ((or (not (setq data (loop-lookup-keyword
1224                                                       key (loop-universe-keywords *loop-universe*))))
1225                                     (progn (apply (symbol-function (car data)) (cdr data))
1226                                            (null *loop-body*)))
1227                                 (loop-error
1228                                   "~S does not introduce a LOOP clause that can follow ~S."
1229                                   key for))
1230                                (t (setq body (nreconc *loop-body* body)))))))
1231               (setq first-clause-p nil)
1232               (if (loop-tequal (car *loop-source-code*) :and)
1233                   (loop-pop-source)
1234                   (return (if (cdr body) `(progn ,@(nreverse body)) (car body)))))))
1235      (let ((then (get-clause for))
1236            (else (when (loop-tequal (car *loop-source-code*) :else)
1237                    (loop-pop-source)
1238                    (list (get-clause :else)))))
1239        (when (loop-tequal (car *loop-source-code*) :end)
1240          (loop-pop-source))
1241        (when it-p (setq form `(setq ,it-p ,form)))
1242        (loop-pseudo-body
1243          `(if ,(if negatep `(not ,form) form)
1244               ,then
1245               ,@else))))))
1246
1247
1248(defun loop-do-initially ()
1249  (loop-disallow-conditional :initially)
1250  (push (loop-get-progn) *loop-prologue*))
1251
1252(defun loop-do-finally ()
1253  (loop-disallow-conditional :finally)
1254  (push (loop-get-progn) *loop-epilogue*))
1255
1256(defun loop-do-do ()
1257  (loop-emit-body (loop-get-progn)))
1258
1259(defun loop-do-named ()
1260  (let ((name (loop-pop-source)))
1261    (unless (symbolp name)
1262      (loop-error "~S is an invalid name for your LOOP." name))
1263    (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*)
1264      (loop-error "The NAMED ~S clause occurs too late." name))
1265    (when *loop-names*
1266      (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S."
1267                  (car *loop-names*) name))
1268    (setq *loop-names* (list name nil))))
1269
1270(defun loop-do-return ()
1271  (loop-emit-body (loop-construct-return (loop-get-form))))
1272
1273
1274;;;; Value Accumulation: List
1275
1276
1277(defstruct (loop-collector
1278             (:copier nil)
1279             (:predicate nil))
1280  name
1281  class
1282  (history nil)
1283  (tempvars nil)
1284  dtype
1285  (data nil))                                           ;collector-specific data
1286
1287
1288(defun loop-get-collection-info (collector class default-type)
1289  (let ((form (loop-get-form))
1290        (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
1291        (name (when (loop-tequal (car *loop-source-code*) 'into)
1292                (loop-pop-source)
1293                (loop-pop-source))))
1294    (when (not (symbolp name))
1295      (loop-error "Value accumulation recipient name, ~S, is not a symbol." name))
1296    (unless name
1297      (loop-disallow-aggregate-booleans))
1298    (unless dtype
1299      (setq dtype (or (loop-optional-type) default-type)))
1300    (let ((cruft (find (the symbol name) *loop-collection-cruft*
1301                       :key #'loop-collector-name)))
1302      (cond ((not cruft)
1303             (when (and name (loop-variable-p name))
1304               (loop-error "Variable ~S cannot be used in INTO clause" name))
1305             (push (setq cruft (make-loop-collector
1306                                 :name name :class class
1307                                 :history (list collector) :dtype dtype))
1308                   *loop-collection-cruft*))
1309            (t (unless (eq (loop-collector-class cruft) class)
1310                 (loop-error
1311                   "Incompatible kinds of LOOP value accumulation specified for collecting~@
1312                    ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S."
1313                   name (car (loop-collector-history cruft)) collector))
1314               (unless (equal dtype (loop-collector-dtype cruft))
1315                 (loop-warn
1316                   "Unequal datatypes specified in different LOOP value accumulations~@
1317                   into ~S: ~S and ~S."
1318                   name dtype (loop-collector-dtype cruft))
1319                 (when (eq (loop-collector-dtype cruft) t)
1320                   (setf (loop-collector-dtype cruft) dtype)))
1321               (push collector (loop-collector-history cruft))))
1322      (values cruft form))))
1323
1324
1325(defun loop-list-collection (specifically)      ;NCONC, LIST, or APPEND
1326  (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list)
1327    (let ((tempvars (loop-collector-tempvars lc)))
1328      (unless tempvars
1329        (setf (loop-collector-tempvars lc)
1330              (setq tempvars (list* (loop-gentemp 'loop-list-head-)
1331                                    (loop-gentemp 'loop-list-tail-)
1332                                    (and (loop-collector-name lc)
1333                                         (list (loop-collector-name lc))))))
1334        (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*)
1335        (unless (loop-collector-name lc)
1336          (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars)))))
1337      (ecase specifically
1338        (list (setq form `(list ,form)))
1339        (nconc nil)
1340        (append (unless (and (consp form) (eq (car form) 'list))
1341                  (setq form `(loop-copylist* ,form)))))
1342      (loop-emit-body `(loop-collect-rplacd ,tempvars ,form)))))
1343
1344
1345;;;; Value Accumulation: max, min, sum, count.
1346
1347
1348
1349(defun loop-sum-collection (specifically required-type default-type)    ;SUM, COUNT
1350  (multiple-value-bind (lc form)
1351      (loop-get-collection-info specifically 'sum default-type)
1352    (loop-check-data-type (loop-collector-dtype lc) required-type)
1353    (let ((tempvars (loop-collector-tempvars lc)))
1354      (unless tempvars
1355        (setf (loop-collector-tempvars lc)
1356              (setq tempvars (list (loop-make-variable
1357                                     (or (loop-collector-name lc)
1358                                         (loop-gentemp 'loop-sum-))
1359                                     nil (loop-collector-dtype lc)))))
1360        (unless (loop-collector-name lc)
1361          (loop-emit-final-value (car (loop-collector-tempvars lc)))))
1362      (loop-emit-body
1363        (if (eq specifically 'count)
1364            `(when ,form
1365               (setq ,(car tempvars)
1366                     ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars)))))
1367            `(setq ,(car tempvars)
1368                   (+ ,(hide-variable-reference t (car tempvars) (car tempvars))
1369                      ,form)))))))
1370
1371
1372
1373(defun loop-maxmin-collection (specifically)
1374  (multiple-value-bind (lc form)
1375      (loop-get-collection-info specifically 'maxmin *loop-real-data-type*)
1376    (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*)
1377    (let ((data (loop-collector-data lc)))
1378      (unless data
1379        (setf (loop-collector-data lc)
1380              (setq data (make-loop-minimax
1381                           (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-))
1382                           (loop-collector-dtype lc))))
1383        (unless (loop-collector-name lc)
1384          (loop-emit-final-value (loop-minimax-answer-variable data))))
1385      (loop-note-minimax-operation specifically data)
1386      (push `(with-minimax-value ,data) *loop-wrappers*)
1387      (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form))
1388      )))
1389
1390
1391;;;; Value Accumulation:  Aggregate Booleans
1392
1393;;;ALWAYS and NEVER.
1394;;; Under ANSI these are not permitted to appear under conditionalization.
1395(defun loop-do-always (restrictive negate)
1396  (let ((form (loop-get-form)))
1397    (when restrictive (loop-disallow-conditional))
1398    (loop-disallow-anonymous-collectors)
1399    (loop-emit-body `(,(if negate 'when 'unless) ,form
1400                      ,(loop-construct-return nil)))
1401    (loop-emit-final-value t)))
1402
1403
1404
1405;;;THERIS.
1406;;; Under ANSI this is not permitted to appear under conditionalization.
1407(defun loop-do-thereis (restrictive)
1408  (when restrictive (loop-disallow-conditional))
1409  (loop-disallow-anonymous-collectors)
1410  (loop-emit-final-value)
1411  (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form))
1412                     ,(loop-construct-return *loop-when-it-variable*))))
1413
1414
1415(defun loop-do-while (negate kwd &aux (form (loop-get-form)))
1416  (loop-disallow-conditional kwd)
1417  (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop))))
1418
1419
1420(defun loop-do-with ()
1421  (loop-disallow-conditional :with)
1422  (do ((var) (val) (dtype)) (nil)
1423    (setq var (loop-pop-source)
1424          dtype (loop-optional-type var)
1425          val (cond ((loop-tequal (car *loop-source-code*) :=)
1426                     (loop-pop-source)
1427                     (loop-get-form))
1428                    (t nil)))
1429    (when (and var (loop-variable-p var))
1430      (loop-error "Variable ~S has already been used" var))
1431    (loop-make-variable var val dtype)
1432    (if (loop-tequal (car *loop-source-code*) :and)
1433        (loop-pop-source)
1434        (return (loop-bind-block)))))
1435
1436
1437;;;; The iteration driver
1438
1439(defun loop-hack-iteration (entry)
1440  (flet ((make-endtest (list-of-forms)
1441           (cond ((null list-of-forms) nil)
1442                 ((member t list-of-forms) '(go end-loop))
1443                 (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
1444                                (car list-of-forms)
1445                                (cons 'or list-of-forms))
1446                       (go end-loop))))))
1447    (do ((pre-step-tests nil)
1448         (steps nil)
1449         (post-step-tests nil)
1450         (pseudo-steps nil)
1451         (pre-loop-pre-step-tests nil)
1452         (pre-loop-steps nil)
1453         (pre-loop-post-step-tests nil)
1454         (pre-loop-pseudo-steps nil)
1455         (tem) (data))
1456        (nil)
1457      ;; Note we collect endtests in reverse order, but steps in correct
1458      ;; order.  MAKE-ENDTEST does the nreverse for us.
1459      (setq tem (setq data (apply (symbol-function (first entry)) (rest entry))))
1460      (and (car tem) (push (car tem) pre-step-tests))
1461      (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))
1462      (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
1463      (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
1464      (setq tem (cdr tem))
1465      (when *loop-emitted-body*
1466        (loop-error "Iteration in LOOP follows body code."))
1467      (unless tem (setq tem data))
1468      (when (car tem) (push (car tem) pre-loop-pre-step-tests))
1469      (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
1470      (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
1471      (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
1472      (unless (loop-tequal (car *loop-source-code*) :and)
1473        (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps)
1474                                        (make-endtest pre-loop-post-step-tests)
1475                                        (loop-make-psetq pre-loop-steps)
1476                                        (make-endtest pre-loop-pre-step-tests)
1477                                        *loop-before-loop*)
1478              *loop-after-body* (list* (loop-make-desetq pseudo-steps)
1479                                       (make-endtest post-step-tests)
1480                                       (loop-make-psetq steps)
1481                                       (make-endtest pre-step-tests)
1482                                       *loop-after-body*))
1483        (loop-bind-block)
1484        (return nil))
1485      (loop-pop-source)                         ; flush the "AND"
1486      (when (and (not (loop-universe-implicit-for-required *loop-universe*))
1487                 (setq tem (loop-lookup-keyword
1488                             (car *loop-source-code*)
1489                             (loop-universe-iteration-keywords *loop-universe*))))
1490        ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied.
1491        (loop-pop-source)
1492        (setq entry tem)))))
1493
1494
1495;;;; Main Iteration Drivers
1496
1497
1498;FOR variable keyword ..args..
1499(defun loop-do-for ()
1500  (let* ((var (loop-pop-source))
1501         (data-type (loop-optional-type var))
1502         (keyword (loop-pop-source))
1503         (first-arg nil)
1504         (tem nil))
1505    (setq first-arg (loop-get-form))
1506    (unless (and (symbolp keyword)
1507                 (setq tem (loop-lookup-keyword
1508                             keyword
1509                             (loop-universe-for-keywords *loop-universe*))))
1510      (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword))
1511    (apply (car tem) var first-arg data-type (cdr tem))))
1512
1513(defun loop-do-repeat ()
1514  (loop-disallow-conditional :repeat)
1515  (let ((form (loop-get-form))
1516        (type 'real))
1517    (let ((var (loop-make-variable (loop-gentemp) form type)))
1518      (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*)
1519      (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*)
1520      ;; FIXME: What should
1521      ;;   (loop count t into a
1522      ;;         repeat 3
1523      ;;         count t into b
1524      ;;         finally (return (list a b)))
1525      ;; return: (3 3) or (4 3)? PUSHes above are for the former
1526      ;; variant, L-P-B below for the latter.
1527      )))
1528
1529(defun loop-when-it-variable ()
1530  (or *loop-when-it-variable*
1531      (setq *loop-when-it-variable*
1532            (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
1533
1534
1535;;;; Various FOR/AS Subdispatches
1536
1537
1538;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN
1539;;; is omitted (other than being more stringent in its placement), and like
1540;;; the old "FOR x FIRST y THEN z" when the THEN is present.  I.e., the first
1541;;; initialization occurs in the loop body (first-step), not in the variable binding
1542;;; phase.
1543(defun loop-ansi-for-equals (var val data-type)
1544  (loop-make-iteration-variable var nil data-type)
1545  (cond ((loop-tequal (car *loop-source-code*) :then)
1546         ;;Then we are the same as "FOR x FIRST y THEN z".
1547         (loop-pop-source)
1548         `(() (,var ,(loop-get-form)) () ()
1549           () (,var ,val) () ()))
1550        (t ;;We are the same as "FOR x = y".
1551         `(() (,var ,val) () ()))))
1552
1553
1554(defun loop-for-across (var val data-type)
1555  (loop-make-iteration-variable var nil data-type)
1556  (let ((vector-var (loop-gentemp 'loop-across-vector-))
1557        (index-var (loop-gentemp 'loop-across-index-)))
1558    (multiple-value-bind (vector-form constantp vector-value)
1559        (loop-constant-fold-if-possible val 'vector)
1560      (loop-make-variable
1561        vector-var vector-form
1562        (if (and (consp vector-form) (eq (car vector-form) 'the))
1563            (cadr vector-form)
1564            'vector))
1565      (loop-make-variable index-var 0 'fixnum)
1566      (let* ((length 0)
1567             (length-form (cond ((not constantp)
1568                                 (let ((v (loop-gentemp 'loop-across-limit-)))
1569                                   (push `(setq ,v (length ,vector-var)) *loop-prologue*)
1570                                   (loop-make-variable v 0 'fixnum)))
1571                                (t (setq length (length vector-value)))))
1572             (first-test `(>= ,index-var ,length-form))
1573             (other-test first-test)
1574             (step `(,var (aref ,vector-var ,index-var)))
1575             (pstep `(,index-var (1+ ,index-var))))
1576        (declare (fixnum length))
1577        (when constantp
1578          (setq first-test (= length 0))
1579          (when (<= length 1)
1580            (setq other-test t)))
1581        `(,other-test ,step () ,pstep
1582          ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep)))))))
1583
1584
1585
1586;;;; List Iteration
1587
1588
1589(defun loop-list-step (listvar)
1590  ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any
1591  ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used
1592  ;; as the stepping function.
1593  ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not
1594  ;; recognizing FOO may defeat some LOOP optimizations.
1595  (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by)
1596                        (loop-pop-source)
1597                        (loop-get-form))
1598                       (t '(function cdr)))))
1599    (cond ((and (consp stepper) (eq (car stepper) 'quote))
1600           (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.")
1601           (values `(funcall ,stepper ,listvar) nil))
1602          ((and (consp stepper) (eq (car stepper) 'function))
1603           (values (list (cadr stepper) listvar) (cadr stepper)))
1604          (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function)
1605                               ,listvar)
1606                     nil)))))
1607
1608
1609(defun loop-for-on (var val data-type)
1610  (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val)
1611    (let ((listvar var))
1612      (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type))
1613            (t (loop-make-variable (setq listvar (loop-gentemp)) list nil)
1614               (loop-make-iteration-variable var nil data-type)))
1615      (multiple-value-bind (list-step step-function) (loop-list-step `(the cons ,listvar))
1616        (declare (ignore step-function))
1617        ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind.
1618        (let* ((first-endtest
1619                (hide-variable-reference
1620                 (eq var listvar)
1621                 listvar
1622                 ;; the following should use `atom' instead of `endp', per
1623                 ;; [bug2428]
1624                 `(atom ,listvar)))
1625               (other-endtest first-endtest))
1626          (when (and constantp (listp list-value))
1627            (setq first-endtest (null list-value)))
1628          (cond ((eq var listvar)
1629                 ;;Contour of the loop is different because we use the user's variable...
1630                 `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest
1631                   () () () ,first-endtest ()))
1632                (t (let ((step `(,var (the cons ,listvar))) (pseudo `(,listvar ,list-step)))
1633                     `(,other-endtest ,step () ,pseudo
1634                       ,@(and (not (eq first-endtest other-endtest))
1635                              `(,first-endtest ,step () ,pseudo)))))))))))
1636
1637
1638(defun loop-for-in (var val data-type)
1639  (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val)
1640    (let ((listvar (loop-gentemp 'loop-list-)))
1641      (loop-make-iteration-variable var nil data-type)
1642      (loop-make-variable listvar list 'list)
1643      (multiple-value-bind (list-step step-function) (loop-list-step listvar)
1644        (declare (ignore step-function))
1645        (let* ((first-endtest `(endp ,listvar))
1646               (other-endtest first-endtest)
1647               (step `(,var (car ,listvar)))
1648               (pseudo-step `(,listvar ,list-step)))
1649          (when (and constantp (listp list-value))
1650            (setq first-endtest (null list-value)))
1651          `(,other-endtest ,step () ,pseudo-step
1652            ,@(and (not (eq first-endtest other-endtest))
1653                   `(,first-endtest ,step () ,pseudo-step))))))))
1654
1655
1656;;;; Iteration Paths
1657
1658
1659(defstruct (loop-path
1660             (:copier nil)
1661             (:predicate nil))
1662  names
1663  preposition-groups
1664  inclusive-permitted
1665  function
1666  user-data)
1667
1668
1669(defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data)
1670  (unless (listp names) (setq names (list names)))
1671  ;; Can't do this due to CLOS bootstrapping problems.
1672  (check-type universe loop-universe)
1673  (let ((ht (loop-universe-path-keywords universe))
1674        (lp (make-loop-path
1675              :names (mapcar #'symbol-name names)
1676              :function function
1677              :user-data user-data
1678              :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups)
1679              :inclusive-permitted inclusive-permitted)))
1680    (dolist (name names) (setf (gethash (symbol-name name) ht) lp))
1681    lp))
1682
1683
1684;;; Note:  path functions are allowed to use loop-make-variable, hack
1685;;; the prologue, etc.
1686(defun loop-for-being (var val data-type)
1687  ;; FOR var BEING each/the pathname prep-phrases using-stuff...
1688  ;; each/the = EACH or THE.  Not clear if it is optional, so I guess we'll warn.
1689  (let ((path nil)
1690        (data nil)
1691        (inclusive nil)
1692        (stuff nil)
1693        (initial-prepositions nil))
1694    (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source)))
1695          ((loop-tequal (car *loop-source-code*) :and)
1696           (loop-pop-source)
1697           (setq inclusive t)
1698           (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her))
1699             (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax."
1700                         (car *loop-source-code*)))
1701           (loop-pop-source)
1702           (setq path (loop-pop-source))
1703           (setq initial-prepositions `((:in ,val))))
1704          (t (loop-error "Unrecognizable LOOP iteration path syntax.  Missing EACH or THE?")))
1705    (cond ((not (symbolp path))
1706           (loop-error "~S found where a LOOP iteration path name was expected." path))
1707          ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*))))
1708           (loop-error "~S is not the name of a LOOP iteration path." path))
1709          ((and inclusive (not (loop-path-inclusive-permitted data)))
1710           (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path)))
1711    (let ((fun (loop-path-function data))
1712          (preps (nconc initial-prepositions
1713                        (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t)))
1714          (user-data (loop-path-user-data data)))
1715      (when (symbolp fun) (setq fun (symbol-function fun)))
1716      (setq stuff (if inclusive
1717                      (apply fun var data-type preps :inclusive t user-data)
1718                      (apply fun var data-type preps user-data))))
1719    (when *loop-named-variables*
1720      (loop-error "Unused USING variables: ~S." *loop-named-variables*))
1721    ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back).  Protect the system from the user
1722    ;; and the user from himself.
1723    (unless (member (length stuff) '(6 10))
1724      (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
1725                  path))
1726    (do ((l (car stuff) (cdr l)) (x)) ((null l))
1727      (if (atom (setq x (car l)))
1728          (loop-make-iteration-variable x nil nil)
1729          (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
1730    (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*))
1731    (cddr stuff)))
1732
1733
1734
1735;;;INTERFACE:  Lucid, exported.
1736;;; i.e., this is part of our extended ansi-loop interface.
1737(defun named-variable (name)
1738  (let ((tem (loop-tassoc name *loop-named-variables*)))
1739    (declare (list tem))
1740    (cond ((null tem) (values (loop-gentemp) nil))
1741          (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
1742             (values (cdr tem) t)))))
1743
1744
1745(defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases)
1746  (flet ((in-group-p (x group) (car (loop-tmember x group))))
1747    (do ((token nil)
1748         (prepositional-phrases initial-phrases)
1749         (this-group nil nil)
1750         (this-prep nil nil)
1751         (disallowed-prepositions
1752           (mapcan #'(lambda (x)
1753                       (loop-copylist*
1754                         (find (car x) preposition-groups :test #'in-group-p)))
1755                   initial-phrases))
1756         (used-prepositions (mapcar #'car initial-phrases)))
1757        ((null *loop-source-code*) (nreverse prepositional-phrases))
1758      (declare (symbol this-prep))
1759      (setq token (car *loop-source-code*))
1760      (dolist (group preposition-groups)
1761        (when (setq this-prep (in-group-p token group))
1762          (return (setq this-group group))))
1763      (cond (this-group
1764             (when (member this-prep disallowed-prepositions)
1765               (loop-error
1766                 (if (member this-prep used-prepositions)
1767                     "A ~S prepositional phrase occurs multiply for some LOOP clause."
1768                     "Preposition ~S used when some other preposition has subsumed it.")
1769                 token))
1770             (setq used-prepositions (if (listp this-group)
1771                                         (append this-group used-prepositions)
1772                                         (cons this-group used-prepositions)))
1773             (loop-pop-source)
1774             (push (list this-prep (loop-get-form)) prepositional-phrases))
1775            ((and USING-allowed (loop-tequal token 'using))
1776             (loop-pop-source)
1777             (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
1778               (when (cadr z)
1779                 (if (setq tem (loop-tassoc (car z) *loop-named-variables*))
1780                     (loop-error
1781                       "The variable substitution for ~S occurs twice in a USING phrase,~@
1782                        with ~S and ~S."
1783                       (car z) (cadr z) (cadr tem))
1784                     (push (cons (car z) (cadr z)) *loop-named-variables*)))
1785               (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*)))
1786                 (return nil))))
1787            (t (return (nreverse prepositional-phrases)))))))
1788
1789
1790;;;; Master Sequencer Function
1791
1792
1793(defun loop-sequencer (indexv indexv-type indexv-user-specified-p
1794                          variable variable-type
1795                          sequence-variable sequence-type
1796                          step-hack default-top
1797                          prep-phrases)
1798   (let ((endform nil)                          ;Form (constant or variable) with limit value.
1799         (sequencep nil)                        ;T if sequence arg has been provided.
1800         (testfn nil)                           ;endtest function
1801         (test nil)                             ;endtest form.
1802         (stepby (1+ (or (loop-typed-init indexv-type) 0)))     ;Our increment.
1803         (stepby-constantp t)
1804         (step nil)                             ;step form.
1805         (dir nil)                              ;Direction of stepping: NIL, :UP, :DOWN.
1806         (inclusive-iteration nil)              ;T if include last index.
1807         (start-given nil)                      ;T when prep phrase has specified start
1808         (start-value nil)
1809         (start-constantp nil)
1810         (limit-given nil)                      ;T when prep phrase has specified end
1811         (limit-constantp nil)
1812         (limit-value nil)
1813         )
1814     (when variable (loop-make-iteration-variable variable nil variable-type))
1815     (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
1816       (setq prep (caar l) form (cadar l))
1817       (case prep
1818         ((:of :in)
1819          (setq sequencep t)
1820          (loop-make-variable sequence-variable form sequence-type))
1821         ((:from :downfrom :upfrom)
1822          (setq start-given t)
1823          (cond ((eq prep :downfrom) (setq dir ':down))
1824                ((eq prep :upfrom) (setq dir ':up)))
1825          (multiple-value-setq (form start-constantp start-value)
1826            (loop-constant-fold-if-possible form indexv-type))
1827          (setq indexv (loop-make-iteration-variable indexv form indexv-type)))
1828         ((:upto :to :downto :above :below)
1829          (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up)))
1830                ((loop-tequal prep :to) (setq inclusive-iteration t))
1831                ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down)))
1832                ((loop-tequal prep :above) (setq dir ':down))
1833                ((loop-tequal prep :below) (setq dir ':up)))
1834          (setq limit-given t)
1835          (multiple-value-setq (form limit-constantp limit-value)
1836            (loop-constant-fold-if-possible form indexv-type))
1837          (setq endform (if limit-constantp
1838                            `',limit-value
1839                            (loop-make-variable
1840                              (loop-gentemp 'loop-limit-) form indexv-type))))
1841         (:by
1842           (multiple-value-setq (form stepby-constantp stepby)
1843             (loop-constant-fold-if-possible form indexv-type))
1844           (unless stepby-constantp
1845             (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type)))
1846         (t (loop-error
1847              "~S invalid preposition in sequencing or sequence path.~@
1848               Invalid prepositions specified in iteration path descriptor or something?"
1849              prep)))
1850       (when (and odir dir (not (eq dir odir)))
1851         (loop-error "Conflicting stepping directions in LOOP sequencing path"))
1852       (setq odir dir))
1853     (when (and sequence-variable (not sequencep))
1854       (loop-error "Missing OF or IN phrase in sequence path"))
1855     ;; Now fill in the defaults.
1856     (unless start-given
1857       (loop-make-iteration-variable
1858         indexv
1859         (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0))
1860         indexv-type))
1861     (cond ((member dir '(nil :up))
1862            (when (or limit-given default-top)
1863              (unless limit-given
1864                (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-))
1865                                    nil indexv-type)
1866                (push `(setq ,endform ,default-top) *loop-prologue*))
1867              (setq testfn (if inclusive-iteration '> '>=)))
1868            (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
1869           (t (unless start-given
1870                (unless default-top
1871                  (loop-error "Don't know where to start stepping."))
1872                (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
1873              (when (and default-top (not endform))
1874                (setq endform (loop-typed-init indexv-type) inclusive-iteration t))
1875              (when endform (setq testfn (if inclusive-iteration  '< '<=)))
1876              (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
1877     (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform))))
1878     (when step-hack
1879       (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack))))
1880     (let ((first-test test) (remaining-tests test))
1881       (when (and stepby-constantp start-constantp limit-constantp)
1882         (when (setq first-test (funcall (symbol-function testfn) start-value limit-value))
1883           (setq remaining-tests t)))
1884       `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack
1885         () () ,first-test ,step-hack))))
1886
1887
1888;;;; Interfaces to the Master Sequencer
1889
1890
1891
1892(defun loop-for-arithmetic (var val data-type kwd)
1893  (loop-sequencer
1894    var (loop-check-data-type data-type 'number) t
1895    nil nil nil nil nil nil
1896    (loop-collect-prepositional-phrases
1897      '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
1898      nil (list (list kwd val)))))
1899
1900
1901(defun loop-sequence-elements-path (variable data-type prep-phrases
1902                                    &key fetch-function size-function sequence-type element-type)
1903  (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index)
1904    (let ((sequencev (named-variable 'sequence)))
1905      (list* nil nil                            ; dummy bindings and prologue
1906             (loop-sequencer
1907               indexv 'fixnum indexv-user-specified-p
1908               variable (or data-type element-type)
1909               sequencev sequence-type
1910               `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev)
1911               prep-phrases)))))
1912
1913
1914;;;; Builtin LOOP Iteration Paths
1915
1916
1917#||
1918(loop for v being the hash-values of ht do (print v))
1919(loop for k being the hash-keys of ht do (print k))
1920(loop for v being the hash-values of ht using (hash-key k) do (print (list k v)))
1921(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v)))
1922||#
1923
1924(defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which)
1925  (check-type which (member hash-key hash-value))
1926  (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
1927         (loop-error "Too many prepositions!"))
1928        ((null prep-phrases) (loop-error "Missing OF or IN in iteration path." )))
1929  (let ((ht-var (loop-gentemp 'loop-hashtab-))
1930        (next-fn (loop-gentemp 'loop-hashtab-next-))
1931        (dummy-predicate-var nil)
1932        (post-steps nil))
1933    (multiple-value-bind (other-var other-p)
1934        (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
1935      ;;@@@@ named-variable returns a second value of T if the name was actually
1936      ;; specified, so clever code can throw away the gensym'ed up variable if
1937      ;; it isn't really needed.
1938      (unless other-p (push `(ignorable ,other-var) *loop-declarations*))
1939      ;;The following is for those implementations in which we cannot put dummy NILs
1940      ;; into multiple-value-setq variable lists.
1941      (setq other-p t
1942            dummy-predicate-var (loop-when-it-variable))
1943      (setq variable (or variable (loop-gentemp 'ignore-)))
1944      (let ((key-var nil)
1945            (val-var nil)
1946            (bindings `((,variable nil ,data-type)
1947                        (,ht-var ,(cadar prep-phrases))
1948                        ,@(and other-p other-var `((,other-var nil))))))
1949        (if (eq which 'hash-key)
1950            (setq key-var variable val-var (and other-p other-var))
1951            (setq key-var (and other-p other-var) val-var variable))
1952        (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
1953        (when (or (consp key-var) data-type)
1954          (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-))
1955                             ,@post-steps))
1956          (push `(,key-var nil) bindings))
1957        (when (or (consp val-var) data-type)
1958          (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-))
1959                             ,@post-steps))
1960          (push `(,val-var nil) bindings))
1961        (push `(ignorable ,dummy-predicate-var) *loop-declarations*)
1962        `(,bindings                             ;bindings
1963          ()                                    ;prologue
1964          ()                                    ;pre-test
1965          ()                                    ;parallel steps
1966          (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) (,next-fn)))       ;post-test
1967          ,post-steps)))))
1968
1969
1970(defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types)
1971  (cond ((and prep-phrases (cdr prep-phrases))
1972         (loop-error "Too many prepositions!"))
1973        ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
1974         (loop-error "Unknown preposition ~S" (caar prep-phrases))))
1975  (unless (symbolp variable)
1976    (loop-error "Destructuring is not valid for package symbol iteration."))
1977  (let ((pkg-var (loop-gentemp 'loop-pkgsym-))
1978        (next-fn (loop-gentemp 'loop-pkgsym-next-))
1979        (variable (or variable (loop-gentemp 'ignore-)))
1980        (pkg (or (cadar prep-phrases) '*package*)))
1981    (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*)
1982    (push `(ignorable ,(loop-when-it-variable)) *loop-declarations*)
1983   
1984    `(((,variable nil ,data-type) (,pkg-var ,pkg))
1985      ()
1986      ()
1987      ()
1988      (not (multiple-value-setq (,(progn
1989                                    ;;@@@@ If an implementation can get away without actually
1990                                    ;; using a variable here, so much the better.
1991                                    (loop-when-it-variable))
1992                                 ,variable)
1993             (,next-fn)))
1994      ())))
1995
1996;;;; ANSI Loop
1997
1998(defun make-ansi-loop-universe (extended-p)
1999  (let ((w (make-standard-loop-universe
2000             :keywords `((named (loop-do-named))
2001                         (initially (loop-do-initially))
2002                         (finally (loop-do-finally))
2003                         (do (loop-do-do))
2004                         (doing (loop-do-do))
2005                         (return (loop-do-return))
2006                         (collect (loop-list-collection list))
2007                         (collecting (loop-list-collection list))
2008                         (append (loop-list-collection append))
2009                         (appending (loop-list-collection append))
2010                         (nconc (loop-list-collection nconc))
2011                         (nconcing (loop-list-collection nconc))
2012                         (count (loop-sum-collection count ,*loop-real-data-type* fixnum))
2013                         (counting (loop-sum-collection count ,*loop-real-data-type* fixnum))
2014                         (sum (loop-sum-collection sum number number))
2015                         (summing (loop-sum-collection sum number number))
2016                         (maximize (loop-maxmin-collection max))
2017                         (minimize (loop-maxmin-collection min))
2018                         (maximizing (loop-maxmin-collection max))
2019                         (minimizing (loop-maxmin-collection min))
2020                         (always (loop-do-always t nil))        ; Normal, do always
2021                         (never (loop-do-always t t))   ; Negate the test on always.
2022                         (thereis (loop-do-thereis t))
2023                         (while (loop-do-while nil :while))     ; Normal, do while
2024                         (until (loop-do-while t :until))       ; Negate the test on while
2025                         (when (loop-do-if when nil))   ; Normal, do when
2026                         (if (loop-do-if if nil))       ; synonymous
2027                         (unless (loop-do-if unless t)) ; Negate the test on when
2028                         (with (loop-do-with))
2029                         (repeat (loop-do-repeat)))
2030             :for-keywords '((= (loop-ansi-for-equals))
2031                             (across (loop-for-across))
2032                             (in (loop-for-in))
2033                             (on (loop-for-on))
2034                             (from (loop-for-arithmetic :from))
2035                             (downfrom (loop-for-arithmetic :downfrom))
2036                             (upfrom (loop-for-arithmetic :upfrom))
2037                             (below (loop-for-arithmetic :below))
2038                             (above (loop-for-arithmetic :above))
2039                             (by (loop-for-arithmetic :by))
2040                             (to (loop-for-arithmetic :to))
2041                             (upto (loop-for-arithmetic :upto))
2042                             (downto (loop-for-arithmetic :downto))
2043                             (being (loop-for-being)))
2044             :iteration-keywords '((for (loop-do-for))
2045                                   (as (loop-do-for)))
2046             :type-symbols '(array atom bignum bit bit-vector character compiled-function
2047                                   complex cons double-float fixnum float
2048                                   function hash-table integer keyword list long-float
2049                                   nil null number package pathname random-state
2050                                   ratio rational readtable sequence short-float
2051                                   simple-array simple-bit-vector simple-string
2052                                   simple-vector single-float standard-char
2053                                   stream string base-char
2054                                   symbol t vector)
2055             :type-keywords nil
2056             :ansi (if extended-p :extended t))))
2057    (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
2058                   :preposition-groups '((:of :in))
2059                   :inclusive-permitted nil
2060                   :user-data '(:which hash-key))
2061    (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
2062                   :preposition-groups '((:of :in))
2063                   :inclusive-permitted nil
2064                   :user-data '(:which hash-value))
2065    (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
2066                   :preposition-groups '((:of :in))
2067                   :inclusive-permitted nil
2068                   :user-data '(:symbol-types (:internal :external :inherited)))
2069    (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w
2070                   :preposition-groups '((:of :in))
2071                   :inclusive-permitted nil
2072                   :user-data '(:symbol-types (:external)))
2073    (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w
2074                   :preposition-groups '((:of :in))
2075                   :inclusive-permitted nil
2076                   :user-data '(:symbol-types (:internal :external)))
2077    w))
2078
2079
2080(defparameter *loop-ansi-universe*
2081              (make-ansi-loop-universe nil))
2082
2083
2084(defun loop-standard-expansion (keywords-and-forms environment universe)
2085  (if (and keywords-and-forms (symbolp (car keywords-and-forms)))
2086      (loop-translate keywords-and-forms environment universe)
2087      (let ((tag (gensym)))
2088        `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
2089
2090
2091(fmakunbound 'loop)                     ; Avoid redefinition warning
2092
2093;;;INTERFACE: ANSI
2094(defmacro loop (&environment env &rest keywords-and-forms)
2095  (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
2096
2097(cl:provide "LOOP")
Note: See TracBrowser for help on using the repository browser.