/[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 - (hide 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 wlott 1.1 ;;; -*- Package: LOOP -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the CMU Common Lisp project at
5 ram 1.6 ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.11 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/old-loop.lisp,v 1.11 2010/03/19 15:18:59 rtoy Rel $")
9 ram 1.6 ;;;
10 wlott 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Loop facility, written by William Lott.
13     ;;;
14     (in-package "LOOP")
15 rtoy 1.11 (intl:textdomain "cmucl")
16 wlott 1.1
17     (in-package "LISP")
18 wlott 1.5 (export '(loop loop-finish))
19 wlott 1.1
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 wlott 1.2 (defmacro loop (&rest stuff)
200     "General iteration facility. See the manual for details, 'cause it's
201     very confusing."
202 wlott 1.1 (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 ram 1.7 (when ,temp
289     (return-from ,name ,temp))))))))
290 wlott 1.1 (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 wlott 1.8 (push `(endp ,name) *for-as-sub-term-tests*))
537 wlott 1.1 (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 wlott 1.8 (push `(endp ,temp) *for-as-term-tests*)))))
542 wlott 1.1
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 wlott 1.8 ;; ### This is wrong.
588 wlott 1.1 (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 wlott 1.3 ((loop-keyword-p clause "SYMBOL" "PRESENT-SYMBOL" "EXTERNAL-SYMBOL"
614     "SYMBOLS" "PRESENT-SYMBOLS" "EXTERNAL-SYMBOLS")
615     (let ((package
616 wlott 1.4 (if (or (preposition-p "IN")
617     (preposition-p "OF"))
618 wlott 1.3 (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 wlott 1.1 (t
651 wlott 1.3 (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 wlott 1.1
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 ram 1.9 (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 wlott 1.1
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