source: project/loop/loop-support.scm @ 1

Last change on this file since 1 was 1, checked in by azul, 15 years ago

Import everything.

File size: 37.3 KB
Line 
1;;; **********************************************************************
2;;;
3;;; Copyright (C) 2002 Heinrich Taube (taube@uiuc.edu)
4;;;
5;;; This program is free software; you can redistribute it and/or
6;;; modify it under the terms of the GNU General Public License
7;;; as published by the Free Software Foundation; either version 2
8;;; of the License, or (at your option) any later version.
9;;;
10;;; This program is distributed in the hope that it will be useful,
11;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13;;; GNU General Public License for more details.
14;;;
15;;; **********************************************************************
16
17;;; $Name:  $
18;;; $Revision: 1.1 $
19;;; $Date: 2004/08/30 20:40:47 $
20
21;;;
22;;; Implementation of the CLTL2 loop macro. The following
23;;; non Rev 5 definitions or their equivalents are needed:
24;;;
25;;;   (defmacro (name args . body)
26;;;       to expand loop, when, unless, push and pop
27;;;   (err msg)
28;;;       signal error with message string.
29;;;   (gensym )
30;;;       create new symbol.
31;;;
32
33(declare (export scheme-loop))
34
35(define-macro (push val sym)
36  `(begin (set! ,sym (cons ,val ,sym)) ,sym))
37
38(define-macro (pop sym)
39  (let ((v (gensym "v")))
40    `(let ((,v (car ,sym)))
41       (set! ,sym (cdr ,sym))
42       ,v)))
43
44;;; this next one is a no-op in guile but i need it for the
45;;; automatic cltl2 translation.
46
47(define-macro (function sym) sym)
48
49(define (loop-operator c)          (vector-ref  c 0))
50(define (loop-operator-set! c x)   (vector-set! c 0 x))
51(define (loop-bindings c)          (vector-ref  c 1))
52(define (loop-bindings-set! c x)   (vector-set! c 1 x))
53(define (loop-collectors c)        (vector-ref  c 2))
54(define (loop-collectors-set! c x) (vector-set! c 2 x))
55(define (loop-initially c)         (vector-ref  c 3))
56(define (loop-initially-set! c x)  (vector-set! c 3 x))
57(define (loop-end-tests c)         (vector-ref  c 4))
58(define (loop-end-tests-set! c x)  (vector-set! c 4 x))
59(define (loop-looping c)           (vector-ref  c 5))
60(define (loop-looping-set! c x)    (vector-set! c 5 x))
61(define (loop-stepping c)          (vector-ref  c 6))
62(define (loop-stepping-set! c x)   (vector-set! c 6 x))
63(define (loop-finally c)           (vector-ref  c 7))
64(define (loop-finally-set! c x)    (vector-set! c 7 x))
65(define (loop-returning c)         (vector-ref  c 8))
66(define (loop-returning-set! c x)  (vector-set! c 8 x))
67
68(define (make-loop-clause . args)
69  (let ((v (vector #f '() '() '() '() '() '() '() '())))
70    (if (null? args) v
71        (do ((a args (cddr a)))
72            ((null? a) v)
73          (case (car a)
74            ((operator) (loop-operator-set! v (cadr a)))
75            ((bindings) (loop-bindings-set! v (cadr a)))
76            ((collectors) (loop-collectors-set! v (cadr a)))
77            ((initially) (loop-initially-set! v (cadr a)))
78            ((end-tests) (loop-end-tests-set! v (cadr a)))
79            ((looping) (loop-looping-set! v (cadr a)))
80            ((stepping) (loop-stepping-set! v (cadr a)))
81            ((finally) (loop-finally-set! v (cadr a)))
82            ((returning) (loop-returning-set! v (cadr a))))))))
83
84(define (gather-clauses caller clauses)
85  ;; nconc all clausal expressions into one structure
86  (let ((gather-clause 
87         (lambda (clauses accessor)
88           ;; append data from clauses
89           (do ((l '()))
90               ((null? clauses) l)
91             (set! l (append l (accessor (car clauses))))
92             (set! clauses (cdr clauses))))))
93    (make-loop-clause 'operator caller
94                      'bindings
95                      (gather-clause clauses 
96                                     (function loop-bindings))
97                      'collectors
98                      (gather-clause clauses 
99                                     (function loop-collectors))
100                      'initially 
101                      (gather-clause clauses 
102                                     (function loop-initially))
103                      'end-tests 
104                      (gather-clause clauses 
105                                     (function loop-end-tests))
106                      'looping 
107                      (gather-clause clauses 
108                                     (function loop-looping))
109                      'stepping 
110                      (gather-clause clauses 
111                                     (function loop-stepping))
112                      'finally 
113                      (gather-clause clauses
114                                     (function loop-finally))
115                      'returning 
116                      (gather-clause clauses
117                                     (function loop-returning)))))
118
119(define (loop-op? x ops)
120  (assoc x ops))
121
122(define (loop-variable? x)
123  (symbol? x))
124
125(define (make-binding var val)
126  (list var val))
127
128(define (loop-error ops forms . args)
129  ;; all error messages include error context.
130  (let ((loop-context
131         (lambda (lst ops)
132           ;; return tail of expr up to next op in cdr of tail
133           (do ((h lst)
134                (l '()))
135               ((or (null? lst)
136                    ;; ignore op if in front.
137                    (and (not (eq? h lst))
138                         (loop-op? (car lst) ops)))
139                (reverse l))
140             (set! l (cons (car lst) l))
141             (set! lst (cdr lst))))))
142    (let* ((forms (loop-context forms ops))
143           (msg (with-output-to-string
144                  (lambda ()
145                    (display "LOOP ERROR: ")
146                    (do ((tail args (cdr tail)))
147                        ((null? tail) #f)
148                      (display (car tail)))
149                    (newline)
150                    (display "Iteration context: ")
151                    (if (null? forms) 
152                        (display "()")
153                        (do ((tail forms (cdr tail)))
154                            ((null? tail) #f)
155                          (if (eq? tail forms) (display "'"))
156                          (display (car tail))
157                          (display (if (null? (cdr tail)) "'" " ")))) ) ) ) )
158      (error msg) ) ) )
159
160(define (parse-for forms clauses ops)
161  ;; forms is (FOR ...)
162  (let ((op (loop-op? (car forms) ops)))
163    (if (null? (cdr forms))
164      (loop-error ops forms "Variable expected but source code ran out." )
165      (let ((var (cadr forms)))
166        (if (loop-variable? var)
167          (if (null? (cddr forms))
168            (loop-error ops forms
169                     "'for' clause expected but source code ran out.")
170            ;; find the iteration path in the op
171            (let ((path (assoc (caddr forms) (cdddr op))))
172              ;; path is (<pathop> <parser>)
173              (if (not path)
174                (loop-error ops forms "'" (caddr forms) "'"
175                            " is not valid with 'for'.")
176                ( (cadr path) forms clauses ops))))
177          (loop-error ops forms "Found '" (cadr forms)
178                      "' where a variable expected."))))))
179
180(define (parse-numerical-for forms clauses ops)
181  ;; forms is (FOR <var> <OP> ...)
182  ;; where <OP> is guaranteed to be one of: FROM TO BELOW ABOVE DOWNTO
183  clauses
184  (let ((var (cadr forms))
185        (tail (cddr forms))
186        (bind '())
187        (from #f)
188        (head #f)
189        (last #f)
190        (stop #f)
191        (step #f)
192        (test #f)
193        (incr #f))
194   
195    (do ((next #f))
196        ((or (null? tail) (loop-op? (car tail) ops)))
197      (set! next (pop tail))
198      (when (null? tail)
199        (loop-error ops forms
200                    "Expected expression but source code ran out."))
201      (case next
202        ((from downfrom)
203         (if head (loop-error ops forms "Found '" next "' when '"
204                              head "' in effect."))
205         (set! head next)
206         (set! from (pop tail)))
207        ((below)
208         (if last (loop-error ops forms "Found '" next "' when '"
209                              last "' in effect."))
210         (set! stop (pop tail))
211         (set! last next))
212        ((to)
213         (if last (loop-error ops forms "Found '" next "' when '"
214                              last "' in effect."))
215         (set! stop (pop tail) )
216         (set! last next))
217        ((above )
218         (if last (loop-error ops forms "Found '" next "' when '"
219                              last "' in effect."))
220         (set! stop (pop tail))
221         (set! last next))
222        ((downto )
223         (if last (loop-error ops forms "Found '" next "' when '"
224                              last "' in effect."))
225         (set! stop (pop tail))
226         (set! last next))
227        ((by)
228         (if step (loop-error ops forms "Found duplicate 'by'."))
229         (set! step (pop tail)))
230        (else
231         (loop-error ops forms 
232                     "'" next "' is not valid with 'for'."))))
233    (unless head
234      (set! head 'from))
235    (if (or (eq? head 'downfrom)
236            (eq? last 'downto)
237            (eq? last 'above))
238      (begin
239       (set! incr '-)
240       (if (eq? last 'above)
241         (set! test '<=)
242         (set! test '<)))   ; allow to for downto
243      (begin
244       (set! incr '+)
245       (if (eq? last 'below)
246         (set! test '>=)
247         (set! test '>))))
248   
249    ;; add binding for initial value
250    (push (make-binding var (or from 0)) bind)
251    ;; add binding for non-constant stepping values.
252    (if (not step)
253      (set! step 1)
254      (if (not (number? step))
255        (let ((var (gensym "v")))
256          (push (make-binding var step) bind)
257          (set! step var))))
258    (set! step `(set! ,var (,incr ,var ,step)))
259    (if stop
260      (let ((end (gensym "v")))
261        (push (make-binding end stop) bind)
262        (set! stop (list test var end))))
263    (values (make-loop-clause 'operator 'for
264                              'bindings (reverse bind)
265                              'stepping (list step)
266                              'end-tests (if (not stop)
267                                           '() (list stop)))
268            tail)))
269
270(define (parse-repeat forms clauses ops)
271  ;; forms is (REPEAT <FORM> ...)
272  (if (null? (cdr forms))
273    (loop-error ops forms 
274                "'repeat' clause expected but source code ran out." )
275    (call-with-values (lambda ()
276                        (parse-numerical-for 
277                         (list 'for (gensym "v") 'below (cadr forms))
278                         clauses ops))
279                      (lambda (clause ignore)
280                        ignore
281                        (values clause (cddr forms))))))
282
283(define (parse-sequence-iteration forms clauses ops)
284  ;; tail is (FOR <var> <OP> ...)
285  ;; <OP> is guaranteed to be one of: IN ON ACROSS
286  clauses
287  (let ((head forms)
288        (var (cadr forms))
289        (seq (gensym "v"))
290        (tail (cddr forms))
291        (bind '())
292        (data #f) 
293        (init '()) 
294        (loop '()) 
295        (incr #f)
296        (stop '()) 
297        (step '()) 
298        (type #f))
299   
300    (do ((next #f))
301        ((or (null? tail) (loop-op? (car tail) ops)))
302      (set! next (pop tail))
303      (unless tail
304        (loop-error ops head
305                    "Expression expected but source code ran out." ))
306      (case next
307        ((in on across)
308         (if type (loop-error ops head 
309                              "Extraneous '" next "' when '"
310                              type "' in effect."))
311         (set! type next)
312         (set! data (pop tail)))
313        ((by )
314         (if incr 
315           (loop-error ops head "Duplicate 'by'." )
316           (if (eq? type 'across)
317             (loop-error ops head "'by' is invalid with 'across'." )
318             (set! incr (pop tail)))))
319        (else
320         (loop-error ops head "'" next "' is not valid with 'for'."))))
321    ; add bindings for stepping var and source
322    (push (make-binding var #f) bind)
323    (push (make-binding seq data) bind)
324    (if (eq? type 'across)
325      (let ((pos (gensym "v"))
326            (max (gensym "v")))
327        (push (make-binding pos 0) bind)
328        (push (make-binding max #f) bind)
329        (push `(set! ,max (vector-length ,seq)) init)
330        (push `(set! ,pos (+ 1 ,pos)) step)
331        (push `(set! ,var (vector-ref ,seq ,pos)) loop)
332        (push `(>= ,pos ,max) stop))
333      (begin
334       (if incr
335         (if (and (list? incr) (eq? (car incr) 'quote))
336           (push `(set! ,seq (,(cadr incr) ,seq)) step)
337           (push `(set! ,seq (,incr ,seq)) step))
338         (push `(set! ,seq (cdr ,seq)) step))
339       (push (if (eq? type 'in)
340                `(set! ,var (car ,seq))
341                `(set! ,var ,seq))
342              loop)
343       (push `(null? ,seq) stop)))
344   
345    (values (make-loop-clause 'operator 'for
346                              'bindings (reverse bind)
347                              'end-tests stop
348                              'initially init
349                              'looping loop
350                              'stepping step)
351            tail)))
352
353(define (parse-general-iteration forms clauses ops)
354  ;; forms is (FOR <var> = ...)
355  clauses
356  (let ((head forms)
357        (var (cadr forms))
358        (tail (cddr forms))
359        (init #f)
360        (type #f)
361        (loop #f)
362        (step #f))
363    (do ((next #f))
364        ((or (null? tail) (loop-op? (car tail) ops)))
365      (set! next (pop tail))
366      (unless tail
367        (loop-error ops head 
368                    "Expression expected but source code ran out."))
369      (case next
370        ((= )
371         (when type (loop-error ops head "Duplicate '='."))
372         (set! loop `(set! ,var ,(pop tail)))
373         (set! type next))
374        ((then )
375         (when init (loop-error ops head "Duplicate 'then'."))
376         (set! init loop)
377         (set! loop #f)
378         (set! step `(set! ,var ,(pop tail)))
379         (set! type next))
380        (else
381         (loop-error ops head "'" next "' is not valid with 'for'."))))
382   
383    (values (make-loop-clause 'operator 'for
384                              'bindings (list (make-binding var #f))
385                              'initially (if init (list init) '())
386                              'looping (if loop (list loop) '())
387                              'stepping (if step (list step) '()))
388            tail)))
389
390(define (parse-with forms clauses ops)
391  ;; forms is (WITH <var> = ...)
392  clauses
393  (let ((head forms)
394        (tail (cdr forms))
395        (var #f)
396        (expr #f)
397        (and? #f)
398        (bind '())
399        (init '()))
400    (do ((need #t) 
401         (next #f))
402        ((or (null? tail) (loop-op? (car tail) ops)))
403      (set! next (pop tail))
404      (cond ((and (loop-variable? next) need)
405             (when var
406               (loop-error ops head
407                           "Found '" next "' where 'and' expected."))
408             (when expr
409               (loop-error ops head
410                           "Found '" next "' where 'and' expected."))
411             (set! var next)
412             (set! expr #f)
413             (set! and? #f)
414             (set! need #f))
415            ((eq? next 'and)
416             (if and?
417               (loop-error ops head "Duplicate 'and'.")
418               (if var 
419                 (if expr
420                   (begin
421                    (push (make-binding var #f) bind)
422                    (push `(set! ,var ,expr) init))
423                   (push (make-binding var #f) bind))
424                 (loop-error ops head "Extraneous 'and'.")))
425             (set! var #f)
426             (set! expr #f)
427             (set! and? #t)
428             (set! need #t))
429            ((eq? next '=)
430             (if expr
431               (loop-error ops head 
432                           "Found '=' where 'and' expected.")
433               (set! expr (pop tail))))
434            (else
435             (if need
436               (loop-error ops head
437                           "Found '" next "' where variable expected.")
438               (loop-error ops head "Found '" next
439                           "' where '=' or 'and' expected.")))))
440    (if and? 
441      (loop-error ops head "Extraneous 'and'.")
442      (if var 
443        (if expr
444          (begin (push (make-binding var #f) bind)
445                 (push `(set! ,var ,expr) init))
446          (push (make-binding var #f) bind))))
447   
448    (values (make-loop-clause 'operator 'with
449                              'bindings (reverse bind)
450                              'initially (reverse init))
451            tail)))
452
453(define (parse-do forms clauses ops)
454  clauses
455  (let ((head forms)
456        (oper (pop forms))
457        (body '()))
458    (do ()
459        ((or (null? forms)
460             (loop-op? (car forms) ops))
461         (if (null? body)
462           (loop-error ops head "Missing '" oper "' expression.")
463           (set! body (reverse body))))
464      (push (car forms) body)
465      (set! forms (cdr forms)))
466    (values
467     (make-loop-clause 'operator oper 'looping body)
468     forms)))
469
470(define (parse-finally forms clauses ops)
471  clauses
472  (let ((oper (pop forms))
473        (expr #f))
474    (when (null? forms)
475      (loop-error ops forms "Missing '" oper "' expression."))
476    (set! expr (pop forms))
477    (values (make-loop-clause 'operator oper 'finally (list expr))
478            forms)))
479
480(define (parse-initially forms clauses ops)
481  clauses
482  (let ((oper (pop forms))
483        (expr #f))
484    (when (null? forms)
485      (loop-error ops forms "Missing '" oper "' expression."))
486    (set! expr (pop forms))
487    (values (make-loop-clause 'operator oper 'initially (list expr))
488            forms)))
489
490(define (lookup-collector var clauses)
491  ;; collector is list: (<var> <type> <acc> <head>)
492  ;; returns the clause where the collect variable VAR is
493  ;; actually bound or nil if var hasn't already been bound
494  ;; if var is nil only the single system allocated collecter
495  ;; is possibly returned.
496  (let ((checkthem (lambda (var lis)
497                     (do ((a #f)) 
498                         ((or (null? lis) a) a)
499                       (if (eq? var (car (car lis))) ;collector-var
500                         (set! a (car lis)))
501                       (set! lis (cdr lis))))))
502    (do ((c #f))
503        ((or (null? clauses) c) c)
504      (set! c (checkthem var (loop-collectors (car clauses))))
505      (set! clauses (cdr clauses)))))
506
507(define (compatible-accumulation? typ1 typ2)
508  (let ((l1 '(collect append nconc))
509        (l2 '(never always))
510        (l3 '(minimize maximize)))
511    (or (eq? typ1 typ2)
512        (and (member typ1 l1) (member typ2 l1))
513        (and (member typ1 l2) (member typ2 l2))
514        (and (member typ1 l3) (member typ2 l3)))))
515
516(define (parse-accumulation forms clauses ops)
517  ;; forms is (<op> form ...)
518  ;; where <op> is collect append nconc
519  (let ((save forms)
520        (oper (pop forms))
521        (make-collector (lambda (var type acc head)
522                          (list var type acc head)))
523        (collector-var (lambda (col) (car col)))
524        (collector-type (lambda (col) (cadr col)))
525        (collector-acc (lambda (col) (caddr col)))
526        (collector-head (lambda (col) (cadddr col)))
527        (expr #f)
528        (coll #f)
529        (new? #f)
530        (into #f)
531        (loop '())
532        (bind '())
533        (init '())
534        (tests '())
535        (return '()))
536   
537    (when (null? forms)
538      (loop-error ops forms "Missing '" oper "' expression."))
539    (set! expr (pop forms))
540    (unless (null? forms)
541      (when (eq? (car forms) 'into)
542        (when (null? (cdr forms))
543          (loop-error ops save "Missing 'into' variable."))
544        (if (loop-variable? (cadr forms))
545          (begin (set! into (cadr forms))
546                 (set! forms (cddr forms)))
547          (loop-error ops save "Found '" (car forms)
548                      "' where 'into' variable expected."))))
549   
550    ;; search for a clause that already binds either the user specified
551    ;; accumulator (into) or a system allocated one if no into.
552    ;; system collectors
553    ;;   o only one  allowed, all accumuations must be compatible
554    ;;   o returns value
555    ;;   value collector: (nil <op> <#:acc>)
556    ;;   list collector:  (nil <op> <#:tail> <#:head>)
557    ;; into collectors
558    ;;   o any number allowed
559    ;;   o returns nothing.
560    ;;   value collector: (<into> <op> <into> )
561    ;;   list collector:  (<into> <op> <#:tail> <#:head>)
562    (set! coll (lookup-collector into clauses))
563    (if (not coll)
564      (set! new? #t)
565      ;; accumulator already established by earlier clause
566      ;; check to make sure clauses are compatible.
567      (unless (compatible-accumulation? oper (collector-type coll))
568        (loop-error ops save "'" (collector-type coll)
569                    "' and '" oper "' are incompatible accumulators.")))
570    (case oper 
571      ((sum count)
572       (let ((acc #f))
573         (if new?
574           (begin
575            (set! acc (or into (gensym "v")))
576            (push (make-binding acc 0) bind)
577            ;; coll= (nil <op> <#:acc>) or (<into> <op> <into>)
578            (set! coll (make-collector into oper acc #f))
579            ;; only add a return value if new collector isnt into
580            (if (not into) (push acc return)))
581           (set! acc (collector-acc coll)))
582         (if (eq? oper 'sum)
583           (push `(set! ,acc (+ ,acc ,expr)) loop)
584           (push `(if ,expr (set! ,acc (+ ,acc 1))) loop))))
585      ((minimize maximize)
586       (let ((var (gensym "v"))
587             (opr (if (eq? oper 'minimize) '< '>))
588             (acc #f))
589         (if new?
590           (begin
591            (set! acc (or into (gensym "v")))
592            (push (make-binding acc #f) bind)
593            ;; coll= (nil <op> <#:acc>) or (<into> <op> <into>)
594            (set! coll (make-collector into oper acc #f))
595            ;; only add a return value if new collector isnt into
596            (if (not into) (push `(or ,acc 0) return)))
597           (set! acc (collector-acc coll)))
598         (push (make-binding var #f) bind)
599         (push `(begin (set! ,var ,expr)
600                        (if (or (not ,acc) 
601                                (,opr ,var ,acc))
602                          (set! ,acc ,var)))
603                loop)))
604      ((append collect nconc)
605       ;; for list accumulation a pointer to the tail of the list
606       ;; is updated and the head of the list is returned. any
607       ;; into variable is set to the head inside the loop.
608       (let ((head #f)
609             (tail #f))
610         (if (not new?)
611           (begin (set! tail (collector-acc coll))
612                  (set! head (collector-head coll)))
613           (begin
614            (if into (push (make-binding into #f) bind))
615            (set! tail (gensym "v"))
616            ;; allocate a pointer to the head of list
617            (set! head (gensym "v"))
618            (push (make-binding head '(list #f)) bind)
619            (push (make-binding tail #f) bind)
620            ;; initialize tail to head
621            (push `(set! ,tail ,head) init)
622            (set! coll (make-collector into oper tail head))
623            ;; only add a return value if new collector isnt into
624            (if (not into)
625              (push `(cdr ,head) return))))
626         ;; add loop accumulation forms
627         (if (eq? oper 'append)
628           (begin
629            (push `(set-cdr! ,tail (list-copy ,expr)) loop)
630            (push `(set! ,tail (last-pair ,tail)) loop))
631           (if (eq? oper 'collect)
632             (begin
633              (push `(set-cdr! ,tail (list ,expr)) loop)
634              (push `(set! ,tail (cdr ,tail)) loop))
635             (begin
636              (push `(set-cdr! ,tail ,expr) loop)
637              (push `(set! ,tail (last-pair ,tail)) loop))))
638         ;; update user into variable inside the main loop
639         ;; regardless of whether its a new collector or not
640         (if into
641           (push `(set! ,into (cdr ,head)) loop)))))
642   
643    (values (make-loop-clause 'operator oper
644                              'bindings (reverse bind)
645                              'initially (reverse init)
646                              'looping (reverse loop)
647                              'returning (reverse return)
648                              'collectors (if new? (list coll) '())
649                              'end-tests (reverse tests))
650            forms)))
651
652;(define (loop-stop expr)
653;  `(%done% ,expr))
654
655(define (loop-return expr)
656  `(return ,expr))
657
658(define (parse-while-until forms clauses ops)
659  clauses
660  (let ((head forms)
661        (oper (pop forms))
662        (test #f)
663        (stop '(go #:done)))
664    (when (null? forms)
665      (loop-error ops head "Missing '" oper "' expression."))
666   
667    (case oper
668      ((until ) (set! test (pop forms)))
669      ((while ) (set! test `(not ,(pop forms)))))
670    ;; calls the DONE continuation.
671    (values (make-loop-clause 'operator oper
672                              'looping (list `(if ,test ,stop)))
673            forms)))
674
675(define (parse-thereis forms clauses ops)
676  clauses
677  (let ((oper (car forms))
678        (expr #f)
679        (bool #f)
680        (func #f))
681    (when (null? (cdr forms))
682      (loop-error ops forms "Missing '" (car forms) "' expression." ))
683    (set! expr (cadr forms))
684    ;; fourth element of operator definition must be
685    ;; a function that returns the stop expression.
686    (set! func (cadddr (loop-op? oper ops) ))
687   
688    (case oper
689      ((thereis ) 
690       ;; return true as soon as expr is true or false at end
691       (set! bool #f))
692      ((always )
693       ;; return false as soon as expr is false, or true at end
694       (set! expr `(not ,expr))
695       (set! bool #t))
696      ((never )
697       ;; return false as soon as expr is true, or true at end
698       (set! bool #t)))
699    (set! forms (cddr forms))
700    ;; this calls the RETURN continuation
701    (values (make-loop-clause 'operator 'thereis
702                              'looping 
703                              (list `(if ,expr ,(func (not bool))))
704                              'returning 
705                              (list bool))
706            forms)))
707
708(define (parse-return forms clauses ops)
709  clauses
710  (let ((oper (car forms))
711        (expr #f)
712        (func #f))
713    (when (null? (cdr forms))
714      (loop-error ops forms "Missing '" (car forms) "' expression."))
715    (set! expr (cadr forms))
716    (set! forms (cddr forms))
717    ;; fourth element of operator definition must be
718    ;; a function that returns the stop expression.
719    (set! func (cadddr (loop-op? oper ops) ))
720    ;; this calls the RETURN continuation
721    (values (make-loop-clause 'operator 'return
722                              'looping `(,(func expr)))
723            forms)))
724
725(define (legal-in-conditional? x ops)
726  ;; FIXED (member (loop-operator...))
727  (let ((op (loop-op? x ops)))
728    (if (and op 
729             (not (null? (cddr op)))
730             (eq? (caddr op) 'task)
731             (not (member (car op) '(thereis never always))))
732      op #f)))
733
734(define (parse-then-else-dependents forms clauses ops)
735  (let ((previous forms)
736        (stop? #f)
737        (parsed '()))
738   
739    (do ((op #f)
740         (clause #f)
741         (remains #f))
742        ((or (null? forms) stop?))
743      (set! op (legal-in-conditional? (car forms) ops))
744      (unless op
745        (loop-error ops previous "'" (car forms)
746                    "' is not conditional operator."))
747      ;(multiple-value-setq
748      ; (clause remains)
749      ; ( (cadr op) forms (append clauses parsed) ops))
750      (call-with-values
751       (lambda () ( (cadr op) forms (append clauses parsed) ops))
752       (lambda (a b) (set! clause a) (set! remains b)))
753
754  ;(format #t "~%after call clause=~s forms=~S" clause forms)     
755
756      (set! parsed (append parsed (list clause)))
757      (set! previous forms)
758      (set! forms remains)
759
760      (unless (null? forms)
761        (if (eq? (car forms) 'and)
762          (begin
763           (set! forms (cdr forms))
764           (if (null? forms)
765             (loop-error ops previous "Missing 'and' clause.")))
766          (if (eq? (car forms) 'else)
767            (set! stop? #t)
768            (if (loop-op? (car forms) ops)
769              (set! stop? #t))))))
770    (values parsed forms)))
771
772(define (parse-conditional forms clauses ops)
773  (let ((ops (cons '(else ) ops))
774        (save forms)
775        (oper (car forms))
776        (loop (list))  ; avoid '() because of acl bug
777        (expr (list))
778        (then (list))
779        (else (list)))
780    (when (null? (cdr forms))
781      (loop-error ops save "Missing '" oper "' expression."))
782    (set! forms (cdr forms))
783    (set! expr (pop forms))
784    (when (null? forms)
785      (loop-error ops forms "Missing conditional clause."))
786    (when (eq? oper 'unless)
787      (set! expr (list 'not expr)))
788    (call-with-values
789     (lambda () (parse-then-else-dependents forms clauses ops))
790     (lambda (a b)
791       (set! then a)
792       (set! forms b)))
793
794    ;; combine dependant clauses if more than one
795    (if (not (null? (cdr then)))
796      (set! then (gather-clauses (list) then))
797      (set! then (car then)))
798    (loop-operator-set! then 'if)
799
800    ;; this if expression is hacked so that it is a newly
801    ;; allocated list. otherwise acl and clisp have a
802    ;; nasty structure sharing problem.
803    (set! loop (list 'if expr 
804                     (list-copy `(begin ,@(loop-looping then)))
805                     #f))
806    (when (and (not (null? forms))
807               (eq? (car forms) 'else))
808      (set! forms (cdr forms))
809      (when (null? forms)
810        (loop-error ops save "Missing 'else' clause."))
811      (call-with-values
812       (lambda ()
813         (parse-then-else-dependents 
814          forms (append clauses (list then))
815          ops))
816       (lambda (a b) (set! else a) (set! forms b)))
817      (if (not (null? (cdr else)))
818        (set! else (gather-clauses '() else))
819        (set! else (car else)))
820      (set-car! (cdddr loop) `(begin ,@(loop-looping else)))
821      ;; flush loop forms so we dont gather actions.
822      (loop-looping-set! then '())
823      (loop-looping-set! else '())
824      (set! then (gather-clauses 'if (list then else))))
825    (loop-looping-set! then (list loop))
826    (values then forms)))
827
828(define (parse-clauses forms cond? ops)
829  (if (or (null? forms)
830          (not (symbol? (car forms))))
831    (list (make-loop-clause 'operator 'do 'looping forms))
832    (let ((op-type? (lambda (op type)
833                      (and (not (null? (cddr op)))
834                           (eq? (caddr op) type)))))
835      (let ((previous forms)
836            (clauses '()))
837        (do ((op #f)
838             (clause #f)
839             (remains '())
840             (body '()) )
841            ((null? forms))
842          (if (and cond? (eq? (car forms) 'and))
843            (pop forms))
844          (set! op (loop-op? (car forms) ops))
845          (when (not op)
846            (loop-error ops previous "Found '" (car forms)
847                        "' where operator expected."))
848          ;(multiple-value-setq (clause remains)
849          ;                     ((cadr op) forms clauses ops))
850          (call-with-values
851           (lambda () ( (cadr op) forms clauses ops))
852           (lambda (a b)
853             (set! clause a)
854             (set! remains b)))
855          (if (op-type? op 'task)
856            (set! body op)
857            (if (op-type? op 'iter)
858              (unless (null? body)
859                (loop-error ops previous "'" (car op)
860                            "' clause cannot follow '"
861                            (car body) "'."))))
862          (set! previous forms)
863          (set! forms remains)
864          (set! clauses (append clauses (list clause))))
865        clauses))))
866
867(define (parse-iteration caller forms ops)
868  (gather-clauses caller (parse-clauses forms '() ops)))
869
870;;;
871;;; loop implementation
872;;;
873
874(define *loop-operators*
875  ;; each clause is (<op> <parser> <tag> . <whatever>)
876  (list (list 'with (function parse-with) #f)
877        (list 'initially (function parse-initially) #f)
878        (list 'repeat (function parse-repeat) 'iter)
879        (list 'for (function parse-for) 'iter
880              (list 'from (function parse-numerical-for))
881              (list 'downfrom (function parse-numerical-for))
882              (list 'below (function parse-numerical-for))
883              (list 'to (function parse-numerical-for))
884              (list 'above (function parse-numerical-for))
885              (list 'downto (function parse-numerical-for))
886              (list 'in (function parse-sequence-iteration))
887              (list 'on (function parse-sequence-iteration))
888              (list 'across (function parse-sequence-iteration))
889              (list '= (function parse-general-iteration)))
890        (list 'as (function parse-for) 'iter)
891        (list 'do (function parse-do) 'task)
892        (list 'collect (function parse-accumulation) 'task)
893        (list 'append (function parse-accumulation) 'task)
894        (list 'nconc (function parse-accumulation) 'task)
895        (list 'sum (function parse-accumulation) 'task)
896        (list 'count (function parse-accumulation) 'task)
897        (list 'minimize (function parse-accumulation) 'task)
898        (list 'maximize (function parse-accumulation) 'task)
899        (list 'thereis (function parse-thereis) 'task
900              (function loop-return))
901        (list 'always (function parse-thereis) 'task
902              (function loop-return))
903        (list 'never (function parse-thereis) 'task 
904              (function loop-return))
905        (list 'return (function parse-return) 'task 
906              (function loop-return))
907        (list 'while (function parse-while-until) #f )
908        (list 'until (function parse-while-until) #f )
909        (list 'when (function parse-conditional) 'task)
910        (list 'unless (function parse-conditional) 'task)
911        (list 'if (function parse-conditional) 'task)
912        (list 'finally (function parse-finally) #f)))
913
914;;;
915;;; loop expansions for scheme and cltl2
916;;;
917
918(define (scheme-loop forms)
919  (let ((name (gensym "v"))
920        (parsed (parse-iteration 'loop forms *loop-operators*))
921        (end-test '())
922        (done '(go #:done))
923        (return #f))
924    ;(write (list :parsed-> parsed))
925    ;; cltl2's loop needs a way to stop iteration from with the run
926    ;; block (the done form) and/or immediately return a value
927    ;; (the return form).  scheme doesnt have a block return or a
928    ;; go/tagbody mechanism these conditions are implemented using
929    ;; continuations.  The forms that done and return expand to are
930    ;; not hardwired into the code because this utility is also used
931    ;; by CM's 'process' macro. Instead, the done and return forms
932    ;; are returned by functions assocated with the relevant operator
933    ;; data. For example, the function that returns the return form
934    ;; is stored as the fourth element in the return operator data.
935    ;; and the done function is stored in the while and until op data.
936   
937    ;; the cadddr of the RETURN operator is a function that
938    ;; provides the form for immediately returning a value
939    ;; from the iteration.
940
941    (let ((returnfn (cadddr (assoc 'return *loop-operators*))))
942      (set! return (returnfn
943                    (if (null? (loop-returning parsed))
944                      #f
945                      (car (loop-returning parsed))))))
946           
947    ;; combine any end-tests into a single IF expression
948    ;; that calls the (done) continuation if true. multiple
949    ;; tests are OR'ed togther
950
951    (set! end-test
952          (let ((ends (loop-end-tests parsed)))
953            (if (null? ends)
954              '()
955              (list
956               `(if ,(if (null? (cdr ends))
957                       (car ends)
958                       (cons 'or ends))
959                  ;;  calls the done continuation
960                  ,done 
961                  #f)))))
962    `(let (,@ (loop-bindings parsed))
963       ,@(loop-initially parsed)
964       (call-with-current-continuation
965        (lambda (return)     ; <- (return) returns from this lambda
966          (call-with-current-continuation
967           (lambda (go)  ; <- (go :done) returns from this lambda
968             ;; a named let provides the actual looping mechanism.
969             ;; the various tests and actions may exit via the
970             ;; (done) or (return) continuations.
971             (let ,name () 
972                  ,@end-test
973                  ,@(loop-looping parsed)
974                  ,@(loop-stepping parsed)
975                  (,name))))
976          ;; this is the lexical point for (go :done) continuation.
977          ,@(loop-finally parsed)
978          ;; invoke the RETURN continuation with loop value or #f
979          ,return)))))
980
981;;;
982;;; these two function are never called in scheme but they are
983;;; translated to the cltl sources.
984;;;
985
986#|
987(define-macro (iter . args)
988  (cltl2-loop args))
989
990(define (cltl2-loop forms)
991  (let ((iter nil)
992        (return nil))
993    (setf iter (parse-iteration 'iter forms *loop-operators*))
994    ;; the cadddr of RETURN operator is a function that
995    ;; returns the form for returning from iteration.
996    (setf return (funcall (cadddr (assoc 'return *loop-operators*))
997                          (car (loop-returning iter))))
998    `(, 'let ,(loop-bindings iter)
999             ,@(loop-initially iter)
1000             (block nil
1001               (tagbody
1002                 :loop
1003                 ,@ (let ((tests (loop-end-tests iter)))
1004                      (if tests
1005                        (list `(if ,(if (cdr tests)
1006                                      (cons 'or tests)
1007                                      (car tests))
1008                                 (go #:done)))
1009                        (list)))
1010                    ,@(loop-looping iter)
1011                    ,@(loop-stepping iter)
1012                    (go :loop)
1013                    #:done
1014                    ,@(loop-finally iter)
1015                    ,return)))))
1016|#
1017
1018;;;
1019;;; loop tests.
1020;;;
1021
1022;(loop for i below 10 collect i)
1023;=> (0 1 2 3 4 5 6 7 8 9)
1024
1025;(loop for i to 10 sum i)
1026;=> 55
1027
1028;(loop for i downto -10 count (even? i))
1029;=> 6
1030
1031;(loop for x in '(0 1 2 3 4 5 6 7 8 9) thereis (= x 4))
1032;=> #t
1033
1034;(loop for x in '(0 1 2 3 4 5 6 7 8 9) by 'cddr collect x)
1035;=> (0 2 4 6 8)
1036
1037;(loop for x on '(0 1 2 3 4 5 6 7 8 9) by 'cddr collect x)
1038;=> ((0 1 2 ...) (2 3 4 ...) ...)
1039
1040;(loop for x in '(0 1 2 3 4 5 6 7 8 9) thereis (= x 4))
1041;=> 4
1042
1043;(loop for x in '(0 1 2 3 4 5 6 7 8 9) never (= x 4))
1044
1045;(loop for x in '(0 1 2 3 4 5 6 7 8 9) never (= x 40))
1046
1047;(loop for x in '(0 2 3 4 5 6 7 8 9) always (< x 40))
1048
1049;(loop repeat 10 with x = 0 collect x do (set! x (+ x 1)))
1050
1051;(loop repeat 10 for x = #t then (not x) collect x)
1052
1053;(loop repeat 10 count #t)
1054
1055;(loop repeat 10 count #f)
1056
1057;(loop for i to 10 collect i collect (* 2 i))
1058
1059;(loop for i from -10 to 10 by 2 nconc (list i (- i)))
1060
1061;(loop for i from -10 downto 10 by -1 collect i)  ; -> NIL
1062
1063;(loop for i downfrom 10 downto -10 by 2 collect i)
1064
1065;(loop for i from 10 to -10 by 1 collect i)   ; -> NIL
1066
1067#;
1068(loop for i to 10
1069      for j downfrom 10
1070      collect i collect j)
1071
1072#;
1073(loop with a and b = 'x and c = 2
1074      repeat 10
1075      for x = 1 then 'fred
1076      collect (list x a b c))
1077
1078;(loop for i across (vector 0 1 2 3) append (list i (expt 2 i)))
1079
1080#;
1081(loop repeat 10
1082      for x = (random 100)
1083      minimize x into a
1084      maximize x into b
1085      finally (return (cons a b)))
1086;=> (36 . 98)
1087
1088#;
1089(loop with a = 0 and b = -1
1090      while (< a 10)
1091      sum a into foo
1092      do (set! a (+ a 1))
1093      finally (return (list foo b)))
1094;=> (45 -1)
1095
1096#;
1097(loop for i to 10
1098      for j = (random 10)
1099      if (even? j) collect j
1100      else collect (- j)
1101      and do (format #t "odd: ~s~%" j))
1102
1103#;
1104(loop for i from 0
1105      until (> i 9)
1106      collect i)
1107;=> (0 1 2 3 4 5 6 7 8 9)
1108
1109#;
1110(loop for i from 0
1111      while (< i 9)
1112      when (even? i)
1113      collect i)
1114;=> (0 2 4 6 8)
1115
1116#;
1117(loop for x = (random 10)
1118      for y = -1 then (- x 10)
1119      when (> x 6)
1120      return (list 'hiho x y))
1121;=> (hiho 7 -4)
1122
1123#;
1124(loop repeat 10 for i = (random 100)
1125      collect i)
1126#;
1127(loop repeat 10 for i = (random 3)
1128      for j = (list i 1)
1129      collect j)
1130
1131;; errors:
1132#;
1133(loop with l = (list 0)
1134      for s in spec
1135      for k = s then (+ k s)
1136      do (push k l)
1137      finally (return l))
1138
1139#;
1140(loop with l = (list (encode-interval 'p 1))
1141      for s in spec
1142      for k = (interval s)
1143      then (transpose k (interval s))
1144      do (push k l)
1145      finally (return l))
Note: See TracBrowser for help on using the repository browser.