/[cmucl]/src/code/old-loop.lisp
ViewVC logotype

Contents of /src/code/old-loop.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Fri Mar 19 15:18:59 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.10: +2 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: LOOP -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/old-loop.lisp,v 1.11 2010/03/19 15:18:59 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Loop facility, written by William Lott.
13 ;;;
14 (in-package "LOOP")
15 (intl:textdomain "cmucl")
16
17 (in-package "LISP")
18 (export '(loop loop-finish))
19
20 (in-package "LOOP")
21
22
23 ;;;; Specials used during the parse.
24
25 ;;; These specials hold the different parts of the result as we are generating
26 ;;; them.
27 ;;;
28 (defvar *loop-name*)
29 (defvar *outside-bindings*)
30 (defvar *prologue*)
31 (defvar *inside-bindings*)
32 (defvar *body-forms*)
33 (defvar *iteration-forms*)
34 (defvar *epilogue*)
35 (defvar *result-var*)
36 (defvar *return-value*)
37 (defvar *default-return-value*)
38 (defvar *accumulation-variables*)
39
40 ;;; This special holds the remaining stuff we need to parse.
41 ;;;
42 (defvar *remaining-stuff*)
43
44 ;;; This special holds a value that is EQ only to itself.
45 ;;;
46 (defvar *magic-cookie* (list '<magic-cookie>))
47
48
49 ;;;; Utility functions/macros used by the parser.
50
51 (proclaim '(inline maybe-car maybe-cdr))
52
53 (defun maybe-car (thing)
54 (if (consp thing) (car thing) thing))
55
56 (defun maybe-cdr (thing)
57 (if (consp thing) (cdr thing) thing))
58
59
60 (defmacro loop-keyword-p (thing keyword &rest more-keywords)
61 `(let ((thing ,thing))
62 (and (symbolp thing)
63 (let ((name (symbol-name thing)))
64 (or ,@(mapcar #'(lambda (keyword)
65 `(string= name ,keyword))
66 (cons keyword more-keywords)))))))
67
68 (defun preposition-p (prep)
69 (when (loop-keyword-p (car *remaining-stuff*) prep)
70 (pop *remaining-stuff*)
71 t))
72
73
74 (defun splice-in-subform (form subform)
75 (if (eq form *magic-cookie*)
76 subform
77 (labels ((sub-splice-in-subform (form path)
78 (cond ((atom form)
79 nil)
80 ((member form path)
81 nil)
82 ((eq (car form) *magic-cookie*)
83 (setf (car form) subform)
84 t)
85 (t
86 (let ((new-path (cons form path)))
87 (or (sub-splice-in-subform (car form) new-path)
88 (sub-splice-in-subform (cdr form) new-path)))))))
89 (if (sub-splice-in-subform form nil)
90 form
91 (error "Couldn't find the magic cookie in:~% ~S~%Loop is broken."
92 form)))))
93
94 (defmacro queue-var (where name type &key
95 (initer nil initer-p) (stepper nil stepper-p))
96 `(push (list ,name ,type ,initer-p ,initer ,stepper-p ,stepper)
97 ,where))
98
99 (defvar *default-values* '(nil 0 0.0)
100 "The different possible default values. When we need a default value, we
101 use the first value in this list that is typep the desired type.")
102
103 (defun pick-default-value (var type)
104 (if (consp var)
105 (cons (pick-default-value (car var) (maybe-car type))
106 (pick-default-value (cdr var) (maybe-cdr type)))
107 (dolist (default *default-values*
108 (error "Cannot default variables of type ~S ~
109 (for variable ~S)."
110 type var))
111 (when (typep default type)
112 (return default)))))
113
114 (defun only-simple-types (type-spec)
115 (if (atom type-spec)
116 (member type-spec '(fixnum float t nil))
117 (and (only-simple-types (car type-spec))
118 (only-simple-types (cdr type-spec)))))
119
120
121 (defun build-let-expression (vars)
122 (if (null vars)
123 (values *magic-cookie* *magic-cookie*)
124 (let ((inside nil)
125 (outside nil)
126 (steppers nil)
127 (sub-lets nil))
128 (dolist (var vars)
129 (labels
130 ((process (name type initial-p initial stepper-p stepper)
131 (cond ((atom name)
132 (cond ((not stepper-p)
133 (push (list type name initial) outside))
134 ((not initial-p)
135 (push (list type name stepper) inside))
136 (t
137 (push (list type name initial) outside)
138 (setf steppers
139 (nconc steppers (list name stepper))))))
140 ((and (car name) (cdr name))
141 (let ((temp (gensym (format nil "TEMP-FOR-~A-" name))))
142 (process temp 'list initial-p initial
143 stepper-p stepper)
144 (push (if stepper-p
145 (list (car name)
146 (maybe-car type)
147 nil nil
148 t `(car ,temp))
149 (list (car name)
150 (maybe-car type)
151 t `(car ,temp)
152 nil nil))
153 sub-lets)
154 (push (if stepper-p
155 (list (cdr name)
156 (maybe-cdr type)
157 nil nil
158 t `(cdr ,temp))
159 (list (car name)
160 (maybe-cdr type)
161 t `(cdr ,temp)
162 nil nil))
163 sub-lets)))
164 ((car name)
165 (process (car name)
166 (maybe-car type)
167 initial-p `(car ,initial)
168 stepper-p `(car ,stepper)))
169 ((cdr name)
170 (process (cdr name)
171 (maybe-cdr type)
172 initial-p `(cdr ,initial)
173 stepper-p `(cdr ,stepper))))))
174 (process (first var) (second var) (third var)
175 (fourth var) (fifth var) (sixth var))))
176 (when steppers
177 (push (cons 'psetq steppers)
178 *iteration-forms*))
179 (multiple-value-bind
180 (sub-outside sub-inside)
181 (build-let-expression sub-lets)
182 (values (build-bindings outside sub-outside)
183 (build-bindings inside sub-inside))))))
184
185 (defun build-bindings (vars guts)
186 (if (null vars)
187 guts
188 `(let ,(mapcar #'cdr vars)
189 (declare ,@(mapcar #'build-declare vars))
190 ,guts)))
191
192 (defun build-declare (var)
193 `(type ,(car var) ,(cadr var)))
194
195
196
197 ;;;; LOOP itself.
198
199 (defmacro loop (&rest stuff)
200 "General iteration facility. See the manual for details, 'cause it's
201 very confusing."
202 (if (some #'atom stuff)
203 (parse-loop stuff)
204 (let ((repeat (gensym "REPEAT-"))
205 (out-of-here (gensym "OUT-OF-HERE-")))
206 `(block nil
207 (tagbody
208 ,repeat
209 (macrolet ((loop-finish () `(go ,out-of-here)))
210 ,@stuff)
211 (go ,repeat)
212 ,out-of-here)))))
213
214
215
216 ;;;; The parser.
217
218 ;;; Top level parser. Bind the specials, and call the other parsers.
219 ;;;
220 (defun parse-loop (stuff)
221 (let* ((*prologue* nil)
222 (*outside-bindings* *magic-cookie*)
223 (*inside-bindings* *magic-cookie*)
224 (*body-forms* nil)
225 (*iteration-forms* nil)
226 (*epilogue* nil)
227 (*result-var* nil)
228 (*return-value* nil)
229 (*default-return-value* nil)
230 (*accumulation-variables* nil)
231 (*remaining-stuff* stuff)
232 (name (parse-named)))
233 (loop
234 (when (null *remaining-stuff*)
235 (return))
236 (let ((clause (pop *remaining-stuff*)))
237 (cond ((not (symbolp clause))
238 (error "Invalid clause, ~S, must be a symbol." clause))
239 ((loop-keyword-p clause "INITIALLY")
240 (setf *prologue* (nconc *prologue* (parse-expr-list))))
241 ((loop-keyword-p clause "FINALLY")
242 (parse-finally))
243 ((loop-keyword-p clause "WITH")
244 (parse-with))
245 ((loop-keyword-p clause "FOR" "AS")
246 (parse-for-as))
247 ((loop-keyword-p clause "REPEAT")
248 (parse-repeat))
249 (t
250 (push clause *remaining-stuff*)
251 (return)))))
252 (loop
253 (when (null *remaining-stuff*)
254 (return))
255 (let ((clause (pop *remaining-stuff*)))
256 (cond ((not (symbolp clause))
257 (error "Invalid clause, ~S, must be a symbol." clause))
258 ((loop-keyword-p clause "INITIALLY")
259 (setf *prologue* (nconc *prologue* (parse-expr-list))))
260 ((loop-keyword-p clause "FINALLY")
261 (parse-finally))
262 ((loop-keyword-p clause "WHILE")
263 (setf *body-forms*
264 (nconc *body-forms*
265 `((unless ,(pop *remaining-stuff*)
266 (loop-finish))))))
267 ((loop-keyword-p clause "UNTIL")
268 (setf *body-forms*
269 (nconc *body-forms*
270 `((when ,(pop *remaining-stuff*) (loop-finish))))))
271 ((loop-keyword-p clause "ALWAYS")
272 (setf *body-forms*
273 (nconc *body-forms*
274 `((unless ,(pop *remaining-stuff*)
275 (return-from ,name nil)))))
276 (setf *default-return-value* t))
277 ((loop-keyword-p clause "NEVER")
278 (setf *body-forms*
279 (nconc *body-forms*
280 `((when ,(pop *remaining-stuff*)
281 (return-from ,name nil)))))
282 (setf *default-return-value* t))
283 ((loop-keyword-p clause "THEREIS")
284 (setf *body-forms*
285 (nconc *body-forms*
286 (let ((temp (gensym "THEREIS-")))
287 `((let ((,temp ,(pop *remaining-stuff*)))
288 (when ,temp
289 (return-from ,name ,temp))))))))
290 (t
291 (push clause *remaining-stuff*)
292 (or (maybe-parse-unconditional)
293 (maybe-parse-conditional)
294 (maybe-parse-accumulation)
295 (error "Unknown clause, ~S" clause))))))
296 (let ((again-tag (gensym "AGAIN-"))
297 (end-tag (gensym "THIS-IS-THE-END-")))
298 `(block ,name
299 ,(splice-in-subform
300 *outside-bindings*
301 `(macrolet ((loop-finish () '(go ,end-tag)))
302 (tagbody
303 ,@*prologue*
304 ,again-tag
305 ,(splice-in-subform
306 *inside-bindings*
307 `(progn
308 ,@*body-forms*
309 ,@(nreverse *iteration-forms*)))
310 (go ,again-tag)
311 ,end-tag
312 ,@*epilogue*
313 (return-from ,name
314 ,(or *return-value*
315 *default-return-value*
316 *result-var*)))))))))
317
318 (defun parse-named ()
319 (when (loop-keyword-p (car *remaining-stuff*) "NAMED")
320 (pop *remaining-stuff*)
321 (if (symbolp (car *remaining-stuff*))
322 (pop *remaining-stuff*)
323 (error "Loop name ~S is not a symbol." (car *remaining-stuff*)))))
324
325
326 (defun parse-expr-list ()
327 (let ((results nil))
328 (loop
329 (when (atom (car *remaining-stuff*))
330 (return (nreverse results)))
331 (push (pop *remaining-stuff*) results))))
332
333 (defun parse-finally ()
334 (let ((sub-clause (pop *remaining-stuff*)))
335 (if (loop-keyword-p sub-clause "RETURN")
336 (cond ((not (null *return-value*))
337 (error "Cannot specify two FINALLY RETURN clauses."))
338 ((null *remaining-stuff*)
339 (error "FINALLY RETURN must be followed with an expression."))
340 (t
341 (setf *return-value* (pop *remaining-stuff*))))
342 (progn
343 (unless (loop-keyword-p sub-clause "DO" "DOING")
344 (push sub-clause *remaining-stuff*))
345 (setf *epilogue* (nconc *epilogue* (parse-expr-list)))))))
346
347 (defun parse-with ()
348 (let ((vars nil))
349 (loop
350 (multiple-value-bind (var type) (parse-var-and-type-spec)
351 (let ((initial
352 (if (loop-keyword-p (car *remaining-stuff*) "=")
353 (progn
354 (pop *remaining-stuff*)
355 (pop *remaining-stuff*))
356 (list 'quote
357 (pick-default-value var type)))))
358 (queue-var vars var type :initer initial)))
359 (if (loop-keyword-p (car *remaining-stuff*) "AND")
360 (pop *remaining-stuff*)
361 (return)))
362 (multiple-value-bind
363 (outside inside)
364 (build-let-expression vars)
365 (setf *outside-bindings*
366 (splice-in-subform *outside-bindings* outside))
367 (setf *inside-bindings*
368 (splice-in-subform *inside-bindings* inside)))))
369
370 (defun parse-var-and-type-spec ()
371 (values (pop *remaining-stuff*)
372 (parse-type-spec t)))
373
374 (defun parse-type-spec (default)
375 (cond ((preposition-p "OF-TYPE")
376 (pop *remaining-stuff*))
377 ((and *remaining-stuff*
378 (only-simple-types (car *remaining-stuff*)))
379 (pop *remaining-stuff*))
380 (t
381 default)))
382
383
384
385 ;;;; FOR/AS stuff.
386
387 ;;; These specials hold the vars that need to be bound for this FOR/AS clause
388 ;;; and all of the FOR/AS clauses connected with AND. All the *for-as-vars*
389 ;;; are bound in parallel followed by the *for-as-sub-vars*.
390 ;;;
391 (defvar *for-as-vars*)
392 (defvar *for-as-sub-vars*)
393
394 ;;; These specials hold any extra termination tests. *for-as-term-tests* are
395 ;;; processed after the *for-as-vars* are bound, but before the
396 ;;; *for-as-sub-vars*. *for-as-sub-term-tests* are processed after the
397 ;;; *for-as-sub-vars*.
398
399 (defvar *for-as-term-tests*)
400 (defvar *for-as-sub-term-tests*)
401
402
403 (defun parse-for-as ()
404 (let ((*for-as-vars* nil)
405 (*for-as-term-tests* nil)
406 (*for-as-sub-vars* nil)
407 (*for-as-sub-term-tests* nil))
408 (loop
409 (multiple-value-bind (name type) (parse-var-and-type-spec)
410 (let ((sub-clause (pop *remaining-stuff*)))
411 (cond ((loop-keyword-p sub-clause "FROM" "DOWNFROM" "UPFROM"
412 "TO" "DOWNTO" "UPTO" "BELOW" "ABOVE")
413 (parse-arithmetic-for-as sub-clause name type))
414 ((loop-keyword-p sub-clause "IN")
415 (parse-in-for-as name type))
416 ((loop-keyword-p sub-clause "ON")
417 (parse-on-for-as name type))
418 ((loop-keyword-p sub-clause "=")
419 (parse-equals-for-as name type))
420 ((loop-keyword-p sub-clause "ACROSS")
421 (parse-across-for-as name type))
422 ((loop-keyword-p sub-clause "BEING")
423 (parse-being-for-as name type))
424 (t
425 (error "Invalid FOR/AS subclause: ~S" sub-clause)))))
426 (if (loop-keyword-p (car *remaining-stuff*) "AND")
427 (pop *remaining-stuff*)
428 (return)))
429 (multiple-value-bind
430 (outside inside)
431 (build-let-expression *for-as-vars*)
432 (multiple-value-bind
433 (sub-outside sub-inside)
434 (build-let-expression *for-as-sub-vars*)
435 (setf *outside-bindings*
436 (splice-in-subform *outside-bindings*
437 (splice-in-subform outside sub-outside)))
438 (let ((inside-body
439 (if *for-as-term-tests*
440 `(if (or ,@(nreverse *for-as-term-tests*))
441 (loop-finish)
442 ,*magic-cookie*)
443 *magic-cookie*))
444 (sub-inside-body
445 (if *for-as-sub-term-tests*
446 `(if (or ,@(nreverse *for-as-sub-term-tests*))
447 (loop-finish)
448 ,*magic-cookie*)
449 *magic-cookie*)))
450 (setf *inside-bindings*
451 (splice-in-subform
452 *inside-bindings*
453 (splice-in-subform
454 inside
455 (splice-in-subform
456 inside-body
457 (splice-in-subform
458 sub-inside
459 sub-inside-body))))))))))
460
461 (defun parse-arithmetic-for-as (sub-clause name type)
462 (unless (atom name)
463 (error "Cannot destructure arithmetic FOR/AS variables: ~S" name))
464 (let (start stop (inc 1) dir exclusive-p)
465 (cond ((loop-keyword-p sub-clause "FROM")
466 (setf start (pop *remaining-stuff*)))
467 ((loop-keyword-p sub-clause "DOWNFROM")
468 (setf start (pop *remaining-stuff*))
469 (setf dir :down))
470 ((loop-keyword-p sub-clause "UPFROM")
471 (setf start (pop *remaining-stuff*))
472 (setf dir :up))
473 (t
474 (push sub-clause *remaining-stuff*)))
475 (cond ((preposition-p "TO")
476 (setf stop (pop *remaining-stuff*)))
477 ((preposition-p "DOWNTO")
478 (setf stop (pop *remaining-stuff*))
479 (if (eq dir :up)
480 (error "Can't mix UPFROM and DOWNTO in ~S." name)
481 (setf dir :down)))
482 ((preposition-p "UPTO")
483 (setf stop (pop *remaining-stuff*))
484 (if (eq dir :down)
485 (error "Can't mix DOWNFROM and UPTO in ~S." name)
486 (setf dir :up)))
487 ((preposition-p "ABOVE")
488 (setf stop (pop *remaining-stuff*))
489 (setf exclusive-p t)
490 (if (eq dir :up)
491 (error "Can't mix UPFROM and ABOVE in ~S." name)
492 (setf dir :down)))
493 ((preposition-p "BELOW")
494 (setf stop (pop *remaining-stuff*))
495 (setf exclusive-p t)
496 (if (eq dir :down)
497 (error "Can't mix DOWNFROM and BELOW in ~S." name)
498 (setf dir :up))))
499 (when (preposition-p "BY")
500 (setf inc (pop *remaining-stuff*)))
501 (when (and (eq dir :down) (null start))
502 (error "No default starting value for decremental stepping."))
503 (let ((temp (gensym "TEMP-AMOUNT-")))
504 (queue-var *for-as-sub-vars* temp type :initer inc)
505 (queue-var *for-as-sub-vars* name type
506 :initer (or start 0)
507 :stepper `(,(if (eq dir :down) '- '+) ,name ,temp))
508 (when stop
509 (let ((stop-var (gensym "STOP-VAR-")))
510 (queue-var *for-as-sub-vars* stop-var type :initer stop)
511 (push (list (if (eq dir :down)
512 (if exclusive-p '<= '<)
513 (if exclusive-p '>= '>))
514 name stop-var)
515 *for-as-sub-term-tests*))))))
516
517 (defun parse-in-for-as (name type)
518 (let* ((temp (gensym "LIST-"))
519 (initer (pop *remaining-stuff*))
520 (stepper (if (preposition-p "BY")
521 `(funcall ,(pop *remaining-stuff*) ,temp)
522 `(cdr ,temp))))
523 (queue-var *for-as-vars* temp 'list :initer initer :stepper stepper)
524 (queue-var *for-as-sub-vars* name type :stepper `(car ,temp))
525 (push `(null ,temp) *for-as-sub-term-tests*)))
526
527 (defun parse-on-for-as (name type)
528 (let* ((temp (if (atom name) name (gensym "LIST-")))
529 (initer (pop *remaining-stuff*))
530 (stepper (if (preposition-p "BY")
531 `(funcall ,(pop *remaining-stuff*) ,temp)
532 `(cdr ,temp))))
533 (cond ((atom name)
534 (queue-var *for-as-sub-vars* name type
535 :initer initer :stepper stepper)
536 (push `(endp ,name) *for-as-sub-term-tests*))
537 (t
538 (queue-var *for-as-vars* temp type
539 :initer initer :stepper stepper)
540 (queue-var *for-as-sub-vars* name type :stepper temp)
541 (push `(endp ,temp) *for-as-term-tests*)))))
542
543 (defun parse-equals-for-as (name type)
544 (let ((initer (pop *remaining-stuff*)))
545 (if (preposition-p "THEN")
546 (queue-var *for-as-sub-vars* name type
547 :initer initer :stepper (pop *remaining-stuff*))
548 (queue-var *for-as-vars* name type :stepper initer))))
549
550 (defun parse-across-for-as (name type)
551 (let* ((temp (gensym "VECTOR-"))
552 (length (gensym "LENGTH-"))
553 (index (gensym "INDEX-")))
554 (queue-var *for-as-vars* temp `(vector ,type)
555 :initer (pop *remaining-stuff*))
556 (queue-var *for-as-sub-vars* length 'fixnum
557 :initer `(length ,temp))
558 (queue-var *for-as-vars* index 'fixnum :initer 0 :stepper `(1+ ,index))
559 (queue-var *for-as-sub-vars* name type :stepper `(aref ,temp ,index))
560 (push `(>= ,index ,length) *for-as-term-tests*)))
561
562 (defun parse-being-for-as (name type)
563 (let ((clause (pop *remaining-stuff*)))
564 (unless (loop-keyword-p clause "EACH" "THE")
565 (error "BEING must be followed by either EACH or THE, not ~S"
566 clause)))
567 (let ((clause (pop *remaining-stuff*)))
568 (cond ((loop-keyword-p clause "HASH-KEY" "HASH-KEYS"
569 "HASH-VALUE" "HASH-VALUES")
570 (let ((prep (pop *remaining-stuff*)))
571 (unless (loop-keyword-p prep "IN" "OF")
572 (error "~A must be followed by either IN or OF, not ~S"
573 (symbol-name clause) prep)))
574 (let ((table (pop *remaining-stuff*))
575 (iterator (gensym (format nil "~A-ITERATOR-" name)))
576 (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
577 (key-temp (gensym (format nil "~A-KEY-TEMP-" name)))
578 (value-temp (gensym (format nil "~A-VALUE-TEMP-" name))))
579 (setf *outside-bindings*
580 (splice-in-subform
581 *outside-bindings*
582 `(with-hash-table-iterator (,iterator ,table)
583 ,*magic-cookie*)))
584 (multiple-value-bind
585 (using using-type)
586 (when (preposition-p "USING")
587 ;; ### This is wrong.
588 (parse-var-and-type-spec))
589 (multiple-value-bind
590 (key-var key-type value-var value-type)
591 (if (loop-keyword-p clause "HASH-KEY" "HASH-KEYS")
592 (values name type using using-type)
593 (values using using-type name type))
594 (setf *inside-bindings*
595 (splice-in-subform
596 *inside-bindings*
597 `(multiple-value-bind
598 (,exists-temp ,key-temp ,value-temp)
599 (,iterator)
600 ,@(unless (and key-var value-var)
601 `((declare (ignore ,@(if (null key-var)
602 (list key-temp))
603 ,@(if (null value-var)
604 (list value-temp))))))
605 ,*magic-cookie*)))
606 (push `(not ,exists-temp) *for-as-term-tests*)
607 (when key-var
608 (queue-var *for-as-sub-vars* key-var key-type
609 :stepper key-temp))
610 (when value-var
611 (queue-var *for-as-sub-vars* value-var value-type
612 :stepper value-temp))))))
613 ((loop-keyword-p clause "SYMBOL" "PRESENT-SYMBOL" "EXTERNAL-SYMBOL"
614 "SYMBOLS" "PRESENT-SYMBOLS" "EXTERNAL-SYMBOLS")
615 (let ((package
616 (if (or (preposition-p "IN")
617 (preposition-p "OF"))
618 (pop *remaining-stuff*)
619 '*package*))
620 (iterator (gensym (format nil "~A-ITERATOR-" name)))
621 (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
622 (symbol-temp (gensym (format nil "~A-SYMBOL-TEMP-" name))))
623 (setf *outside-bindings*
624 (splice-in-subform
625 *outside-bindings*
626 `(with-package-iterator
627 (,iterator
628 ,package
629 ,@(cond ((loop-keyword-p clause "SYMBOL" "SYMBOLS")
630 '(:internal :external :inherited))
631 ((loop-keyword-p clause "PRESENT-SYMBOL"
632 "PRESENT-SYMBOLS")
633 '(:internal))
634 ((loop-keyword-p clause "EXTERNAL-SYMBOL"
635 "EXTERNAL-SYMBOLS")
636 '(:external))
637 (t
638 (error "Don't know how to deal with ~A? ~
639 Bug in LOOP?" clause))))
640 ,*magic-cookie*)))
641 (setf *inside-bindings*
642 (splice-in-subform
643 *inside-bindings*
644 `(multiple-value-bind
645 (,exists-temp ,symbol-temp)
646 (,iterator)
647 ,*magic-cookie*)))
648 (push `(not ,exists-temp) *for-as-term-tests*)
649 (queue-var *for-as-sub-vars* name type :stepper symbol-temp)))
650 (t
651 (error
652 "Unknown sub-clause, ~A, for BEING. Must be one of:~% ~
653 HASH-KEY HASH-KEYS HASH-VALUE HASH-VALUES SYMBOL SYMBOLS~% ~
654 PRESENT-SYMBOL PRESENT-SYMBOLS EXTERNAL-SYMBOL EXTERNAL-SYMBOLS"
655 (symbol-name clause))))))
656
657
658
659 ;;;;
660
661 (defun parse-repeat ()
662 (let ((temp (gensym "REPEAT-")))
663 (setf *outside-bindings*
664 (splice-in-subform *outside-bindings*
665 `(let ((,temp ,(pop *remaining-stuff*)))
666 ,*magic-cookie*)))
667 (setf *inside-bindings*
668 (splice-in-subform *inside-bindings*
669 `(if (minusp (decf ,temp))
670 (loop-finish)
671 ,*magic-cookie*)))))
672
673
674 (defun maybe-parse-unconditional ()
675 (cond ((loop-keyword-p (car *remaining-stuff*) "DO" "DOING")
676 (pop *remaining-stuff*)
677 (setf *body-forms* (nconc *body-forms* (parse-expr-list)))
678 t)
679 ((loop-keyword-p (car *remaining-stuff*) "RETURN")
680 (pop *remaining-stuff*)
681 (setf *body-forms*
682 (nconc *body-forms* `((return ,(pop *remaining-stuff*)))))
683 t)))
684
685
686 (defun maybe-parse-conditional ()
687 (let ((clause (pop *remaining-stuff*)))
688 (cond ((loop-keyword-p clause "IF" "WHEN")
689 (parse-conditional (pop *remaining-stuff*))
690 t)
691 ((loop-keyword-p clause "UNLESS")
692 (parse-conditional `(not ,(pop *remaining-stuff*)))
693 t)
694 (t
695 (push clause *remaining-stuff*)
696 nil))))
697
698 (defun parse-conditional (condition)
699 (let ((clauses (parse-and-clauses))
700 (else-clauses (when (preposition-p "ELSE")
701 (parse-and-clauses))))
702 (setf *body-forms*
703 (nconc *body-forms*
704 `((if ,condition
705 (progn
706 ,@clauses)
707 (progn
708 ,@else-clauses)))))
709 (preposition-p "END")))
710
711 (defun parse-and-clauses ()
712 (let ((*body-forms* nil))
713 (loop
714 (or (maybe-parse-unconditional)
715 (maybe-parse-conditional)
716 (maybe-parse-accumulation)
717 (error "Invalid clause for inside a conditional: ~S"
718 (car *remaining-stuff*)))
719 (unless (preposition-p "AND")
720 (return *body-forms*)))))
721
722
723 ;;;; Assumulation stuff
724
725 (defun maybe-parse-accumulation ()
726 (when (loop-keyword-p (car *remaining-stuff*)
727 "COLLECT" "COLLECTING"
728 "APPEND" "APPENDING" "NCONC" "NCONCING"
729 "COUNT" "COUNTING" "SUM" "SUMMING"
730 "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING")
731 (parse-accumulation)
732 t))
733
734 (defun parse-accumulation ()
735 (let* ((clause (pop *remaining-stuff*))
736 (expr (pop *remaining-stuff*))
737 (var (if (preposition-p "INTO")
738 (pop *remaining-stuff*)
739 (or *result-var*
740 (setf *result-var*
741 (gensym (concatenate 'simple-string
742 (string clause)
743 "-"))))))
744 (info (assoc var *accumulation-variables*))
745 (type nil)
746 (initial nil))
747 (cond ((loop-keyword-p clause "COLLECT" "COLLECTING" "APPEND" "APPENDING"
748 "NCONC" "NCONCING")
749 (setf initial nil)
750 (setf type 'list)
751 (let ((aux-var
752 (or (caddr info)
753 (let ((aux-var (gensym "LAST-")))
754 (setf *outside-bindings*
755 (splice-in-subform *outside-bindings*
756 `(let ((,var nil)
757 (,aux-var nil))
758 (declare (type list
759 ,var
760 ,aux-var))
761 ,*magic-cookie*)))
762 (if (null info)
763 (push (setf info (list var 'list aux-var))
764 *accumulation-variables*)
765 (setf (cddr info) (list aux-var)))
766 aux-var)))
767 (value
768 (cond ((loop-keyword-p clause "COLLECT" "COLLECTING")
769 `(list ,expr))
770 ((loop-keyword-p clause "APPEND" "APPENDING")
771 `(copy-list ,expr))
772 ((loop-keyword-p clause "NCONC" "NCONCING")
773 expr)
774 (t
775 (error "Bug in loop?")))))
776 (setf *body-forms*
777 (nconc *body-forms*
778 `((cond ((null ,var)
779 (setf ,var ,value)
780 (setf ,aux-var (last ,var)))
781 (t
782 (nconc ,aux-var ,value)
783 (setf ,aux-var (last ,aux-var)))))))))
784 ((loop-keyword-p clause "COUNT" "COUNTING")
785 (setf type (parse-type-spec 'unsigned-byte))
786 (setf initial 0)
787 (setf *body-forms*
788 (nconc *body-forms*
789 `((when ,expr (incf ,var))))))
790 ((loop-keyword-p clause "SUM" "SUMMING")
791 (setf type (parse-type-spec 'number))
792 (setf initial 0)
793 (setf *body-forms*
794 (nconc *body-forms*
795 `((incf ,var ,expr)))))
796 ((loop-keyword-p clause "MAXIMIZE" "MAXIMIZING")
797 (setf type `(or null ,(parse-type-spec 'number)))
798 (setf initial nil)
799 (setf *body-forms*
800 (nconc *body-forms*
801 (let ((temp (gensym "MAX-TEMP-")))
802 `((let ((,temp ,expr))
803 (when (or (null ,var)
804 (> ,temp ,var))
805 (setf ,var ,temp))))))))
806 ((loop-keyword-p clause "MINIMIZE" "MINIMIZING")
807 (setf type `(or null ,(parse-type-spec 'number)))
808 (setf initial nil)
809 (setf *body-forms*
810 (nconc *body-forms*
811 (let ((temp (gensym "MIN-TEMP-")))
812 `((let ((,temp ,expr))
813 (when (or (null ,var)
814 (< ,temp ,var))
815 (setf ,var ,temp))))))))
816 (t
817 (error "Invalid accumulation clause: ~S" clause)))
818 (cond (info
819 (unless (equal type (cadr info))
820 (error "Attempt to use ~S for both types ~S and ~S."
821 var type (cadr info))))
822 (t
823 (push (list var type) *accumulation-variables*)
824 (setf *outside-bindings*
825 (splice-in-subform *outside-bindings*
826 `(let ((,var ,initial))
827 (declare (type ,type ,var))
828 ,*magic-cookie*)))))))

  ViewVC Help
Powered by ViewVC 1.1.5