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