source: trunk/j/src/org/armedbear/lisp/loop.lisp @ 5887

Last change on this file since 5887 was 5887, checked in by piso, 18 years ago

Use SBCL's LOOP.

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