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