source: project/release/4/fast-loop/trunk/fast-loop.scm @ 14322

Last change on this file since 14322 was 14322, checked in by Alex Shinn, 11 years ago

adding accumulators, hash-table support, while/until

File size: 18.0 KB
Line 
1;;;; fast-loop.scm - loop macro customized for Chicken
2;;
3;; Copyright (c) 2009 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6;; The loop API is compatible with Taylor Campbell's foof-loop, but
7;; the iterator API is different and subject to change.  All loop
8;; variables may be implicitly destructured with MATCH semantics.
9
10;; Unsafe operations have been inlined where they can be proven safe.
11
12(require-extension matchable srfi-1)
13
14(module fast-loop
15 (loop in-list in-lists in-vector in-vector-reverse
16  in-string in-string-reverse in-port in-file
17  in-hash-table up-from down-from
18  listing listing-reverse
19  (appending append-reverse) (appending-reverse append-reverse)
20  define-in-indexed)
21
22(import scheme chicken matchable srfi-1)
23
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25
26(define-syntax let-keyword-form
27  (syntax-rules ()
28    ((let-keyword-form
29      ((labeled-arg-macro-name
30        (positional-form-name (arg-name . arg-default) ...)))
31      . body)
32     (letrec-syntax
33         ((labeled-arg-macro-name
34           (syntax-rules ()
35             ((labeled-arg-macro-name . keyword-val-pairs)
36              (letrec-syntax
37                  ((find
38                    (syntax-rules (=> arg-name ...)
39                      ((find kvp k-args (arg-name . default) (=> arg-name val)
40                             . others) ; found arg-name among keyword-val-pairs
41                       (next kvp val . k-args)) ...
42                      ((find kvp k-args key (=> arg-no-match-name val) . others)
43                       (find kvp k-args key . others))
44                      ;; default must be here
45                      ((find kvp k-args (arg-name default))
46                       (next kvp default . k-args)) ...
47                      ))
48                   (next               ; pack the continuation to find
49                    (syntax-rules ()
50                      ((next kvp val vals key . keys)
51                       (find kvp ((val . vals) . keys) key . kvp))
52                      ((next kvp val vals) ; processed all arg-descriptors
53                       (rev-apply (val) vals))))
54                   (match-positionals
55                    (syntax-rules (=>)
56                      ((match-positionals () res . rest)
57                       (rev-apply () res))
58                      ((match-positionals args (val . vals) (=> name value)
59                                          . rest)
60                       (next ((=> name value) . rest) val vals . args))
61                      ((match-positionals args (val . vals))
62                       (next () val vals . args))
63                      ((match-positionals (arg1 . args) res pos-arg . rest)
64                       (match-positionals args (pos-arg . res) . rest))))
65                   (rev-apply
66                    (syntax-rules ()
67                      ((rev-apply form (x . xs))
68                       (rev-apply (x . form) xs))
69                      ((rev-apply form ()) form))))
70                (match-positionals ((arg-name . arg-default) ...)
71                                   (positional-form-name)
72                                   . keyword-val-pairs)
73                )))))
74       . body))))
75
76;; (define-syntax let-keyword-form
77;;   (syntax-rules ()
78;;     ((let-keyword-form
79;;       ((labeled-arg-macro-name (positional-name (arg default) ...)))
80;;       . body)
81;;      (letrec-syntax
82;;          ((labeled-arg-macro-name
83;;            (er-macro-transformer
84;;             (lambda (expr rename compare)
85;;               (receive (named posns)
86;;                   (partition (lambda (x) (and (list? x) (compare (car x) '=>)))
87;;                              (cdr expr))
88;;                 (let lp ((ls '((arg default) ...)) (posns posns) (args '()))
89;;                   (cond
90;;                    ((null? ls)
91;;                     (if (pair? posns)
92;;                         (error "let-keyword-form: too many args" expr)
93;;                         (cons 'positional-name (reverse args))))
94;;                    ((find (lambda (x) (compare (caar ls) (cadr x))) named)
95;;                     => (lambda (x)
96;;                          (lp (cdr ls) posns (cons (caddr x) args))))
97;;                    ((pair? posns)
98;;                     (lp (cdr ls) (cdr posns) (cons (car posns) args)))
99;;                    (else
100;;                     (lp (cdr ls) posns (cons (cadar ls) args))))))))))
101;;        . body))))
102
103;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104
105(define-syntax loop
106  (syntax-rules ()
107    ;; unnamed, implicit recursion
108    ((loop (vars ...) body ...)
109     (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
110    ;; named, explicit recursion
111    ((loop name (vars ...) body ...)
112     (%loop name () () () () () (vars ...) body ...))))
113
114;; Main LOOP macro. Separate the variables from the iterator and
115;; parameters, then walk through each parameter expanding the
116;; bindings, and build the final form.
117
118(define-syntax %loop
119  (syntax-rules (=> for with let while until)
120    ;; automatic iteration
121    ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body)
122     (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body))
123    ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body)
124     (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body))
125    ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body)
126     (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body))
127    ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body)
128     (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body))
129    ;; do equivalents, with optional guards
130    ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body)
131     (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body))
132    ((_ name l (vars ...) c r f ((with var init step) rest ...) . body)
133     (%loop name l (vars ... (var init step)) c r f (rest ...) . body))
134    ((_ name l (vars ...) c r f ((with var init) rest ...) . body)
135     (%loop name l (vars ... (var init var)) c r f (rest ...) . body))
136    ;; user-specified terminators
137    ((_ name l vars (checks ...) r f ((while expr) rest ...) . body)
138     (%loop name l vars (checks ... expr) r f (rest ...) . body))
139    ((_ name l vars (checks ...) r f ((until expr) rest ...) . body)
140     (%loop name l vars (checks ... (not expr)) r f (rest ...) . body))
141    ;; specify a default done?
142    ((_ name l v c r f ())
143     (%loop name l v c r f () (#f #f)))
144    ((_ name l v c r f () () . body)
145     (%loop name l v c r f () (#f #f) . body))
146    ;; final expansion
147    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
148        => result
149        . body)
150     (let* (lets ...)
151       (letrec ((tmp (lambda (var ...)
152                       (if (or checks ...)
153                           (let-keyword-form ((name (tmp (var step) ...)))
154                             (match-let (finals ...) result))
155                           (match-let (refs ...)
156                             (let-keyword-form ((name (tmp (var step) ...)))
157                               (if #f #f)
158                               . body))))))
159         (tmp init ...))))
160    ;; unspecified return value case
161    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
162        . body)
163     (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
164            => (if #f #f) . body))
165    ))
166
167(define-syntax %loop-next
168  (syntax-rules ()
169    ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
170        name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
171        . rest)
172     (%loop name (lets ... new-lets ...) (vars ... new-vars ...)
173                 (checks ... new-checks ...) (refs ... new-refs ...)
174                 (finals ... new-finals ...)
175        . rest))))
176
177;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
178;; Iterators
179
180;; Each gets passed two lists, those items left of the <- and those to
181;; the right, followed by a NEXT and REST continuation.
182
183;; Should finish with
184;;
185;;  (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
186;;        (loop-vars ...) (final-vars ...) . rest)
187;;
188;;  OUTER-VARS: bound once outside the loop in a LET*
189;;  CURSOR-VARS: DO-style bindings of the form (name init update)
190;;  DONE?-TESTS: possibly empty list of forms that terminate the loop on #t
191;;  LOOP-VARS: inner variables, updated in parallel after the cursors
192;;  FINAL-VARS: final variables, bound only in the => result
193
194(define-syntax in-list                  ; called just "IN" in ITER
195  (syntax-rules ()
196    ((in-list ((var) source) next . rest)
197     (in-list ((var cursor) source) next . rest))
198    ((in-list ((var cursor) source) next . rest)
199     (in-list ((var cursor succ) source) next . rest))
200    ((in-list ((var cursor succ) (source)) next . rest)
201     (next ()                              ; outer let bindings
202           ((cursor source succ))          ; iterator, init, step
203           ((not (pair? cursor)))          ; finish tests for iterator vars
204           ;; step variables and values
205           ((var (cond-expand ((and chicken compiling)
206                               (##core#inline "C_u_i_car" cursor))
207                              (else (car cursor))))
208            (succ (cond-expand ((and chicken compiling)
209                                (##core#inline "C_u_i_cdr" cursor))
210                              (else (cdr cursor)))))
211           ()                              ; final result bindings
212           . rest))
213    ((in-list ((var cursor succ) (source step)) next . rest)
214     (next ()
215           ((cursor source succ))
216           ((not (pair? cursor)))
217           ((var (cond-expand ((and chicken compiling)
218                               (##core#inline "C_u_i_car" cursor))
219                              (else (car cursor))))
220            (succ (step cursor)))
221           ()
222           . rest))))
223
224;; Iterator from Taylor R. Campbell.  If you know the number of lists
225;; ahead of time it's much more efficient to iterate over each one
226;; separately.
227(define-syntax in-lists
228  (syntax-rules ()
229    ((in-lists ((elts) lol) next . rest)
230     (in-lists ((elts pairs) lol) next . rest))
231    ((in-lists ((elts pairs) lol) next . rest)
232     (in-lists ((elts pairs succ) lol) next . rest))
233    ((in-lists ((elts pairs succ) (lol)) next . rest)
234     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
235    ((in-lists ((elts pairs succ) (lol)) next . rest)
236     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
237    ((in-lists ((elts pairs succ) (lol step)) next . rest)
238     (in-lists ((elts pairs succ) (lol step null?)) next . rest))
239    ((in-lists ((elts pairs succ) (lol step done?)) next . rest)
240     (next ()
241           ((pairs lol succ))
242           ((let lp ((ls pairs)) ; an in-lined ANY
243              (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
244           ((elts (map car pairs))
245            (succ (map step pairs)))
246           ()
247           . rest))
248    ))
249
250(define-syntax define-in-indexed
251  (syntax-rules ()
252    ((define-in-indexed in-type in-type-reverse length ref)
253     (begin
254       (define-syntax in-type
255         (syntax-rules ()
256           ((in-type ls next . rest)
257            (%in-idx fx>= fx+ 0 (length tmp) ref tmp ls next . rest))))
258       (define-syntax in-type-reverse
259         (syntax-rules ()
260           ((in-type-reverse ls next . rest)
261            (%in-idx fx< fx- (fx- (length tmp) 1) 0 ref tmp ls next . rest))))
262       ))))
263
264(define-in-indexed in-string in-string-reverse string-length string-ref)
265(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
266
267;; helper for the above string and vector iterators
268(define-syntax %in-idx
269  (syntax-rules ()
270    ;;   cmp inc start end ref
271    ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest)
272     (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest))
273    ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest)
274     (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest))
275    ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest)
276     (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest))
277    ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest)
278     (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest))
279    ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest)
280     (next ((tmp-vec vec) (end to))
281           ((index from (+ index step)))
282           ((ge index end))
283           ((var (r tmp-vec index)))
284           ()
285       . rest))
286    ))
287
288(define-syntax in-port
289  (syntax-rules ()
290    ((in-port ((var) source) next . rest)
291     (in-port ((var p) source) next . rest))
292    ((in-port ((var p) ()) next . rest)
293     (in-port ((var p) ((current-input-port))) next . rest))
294    ((in-port ((var p) (port)) next . rest)
295     (in-port ((var p) (port read-char)) next . rest))
296    ((in-port ((var p) (port read-char)) next . rest)
297     (in-port ((var p) (port read-char eof-object?)) next . rest))
298    ((in-port ((var p) (port reader eof?)) next . rest)
299     (next ((p port) (r reader) (e? eof?))
300           ((var (r p) (r p)))
301           ((e? var))
302           ()
303           ()
304       . rest))))
305
306(define-syntax in-file
307  (syntax-rules ()
308    ((in-file ((var) source) next . rest)
309     (in-file ((var p) source) next . rest))
310    ((in-file ((var p) (file)) next . rest)
311     (in-file ((var p) (file read-char)) next . rest))
312    ((in-file ((var p) (file reader)) next . rest)
313     (in-file ((var p) (file reader eof-object?)) next . rest))
314    ((in-file ((var p) (file reader eof?)) next . rest)
315     (next ((p (open-input-file file)) (r reader) (e? eof?))
316           ((var (r p) (r p)))
317           ((e? var))
318           ()
319           ((dummy (close-input-port p)))
320       . rest))))
321
322(define-syntax up-from
323  (syntax-rules (to by)
324    ((up-from (() . args) next . rest)
325     (up-from ((var) . args) next . rest))
326    ((up-from ((var) (start (to limit) (by step))) next . rest)
327     (next ((s start) (l limit) (e step))
328           ((var s (+ var e)))
329           ((>= var limit))
330           ()
331           ()
332           . rest))
333    ((up-from ((var) (start (to limit))) next . rest)
334     (next ((s start) (l limit))
335           ((var s (+ var 1)))
336           ((>= var limit))
337           ()
338           ()
339           . rest))
340    ((up-from ((var) (start (by step))) next . rest)
341     (next ((s start) (l limit) (e step)) ((var s (+ var e))) () () () . rest))
342    ))
343
344(define-syntax down-from
345  (syntax-rules (to by)
346    ((down-from (() . args) next . rest)
347     (down-from ((var) . args) next . rest))
348    ((down-from ((var) (start (to limit) (by step))) next . rest)
349     (next ((s start) (l limit) (e step))
350           ((var (- s e) (- var e)))
351           ((< var limit))
352           ()
353           ()
354           . rest))
355    ((down-from ((var) (start (to limit))) next . rest)
356     (next ((s start) (l limit))
357           ((var (- s 1) (- var 1)))
358           ((< var limit))
359           ()
360           ()
361           . rest))
362    ((down-from ((var) (start (by step))) next . rest)
363     (next ((s start) (l limit) (e step)) ((var (- s e) (- var e))) () () ()
364           . rest))
365    ))
366
367(define-syntax accumulating
368  (syntax-rules (initial if)
369    ((accumulating (kons final init) ((var) . x) next . rest)
370     (accumulating (kons final init) ((var cursor) . x) next . rest))
371    ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
372     (accumulating (kons final i) ((var cursor) x) n . rest))
373    ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
374     (n ((tmp-kons kons))
375        ((cursor '() (if check (tmp-kons expr cursor) cursor)))
376        ()
377        ()
378        ((var (final cursor)))
379        . rest))
380    ((accumulating (kons final init) ((var cursor) (expr)) n . rest)
381     (n ((tmp-kons kons))
382        ((cursor '() (tmp-kons expr cursor)))
383        ()
384        ()
385        ((var (final cursor)))
386        . rest))))
387
388(define-syntax listing
389  (syntax-rules ()
390    ((listing args next . rest)
391     (accumulating (cons reverse '()) args next . rest))))
392
393(define-syntax listing-reverse
394  (syntax-rules ()
395    ((listing-reverse args next . rest)
396     (accumulating (cons (lambda (x) x) '()) args next . rest))))
397
398(define-syntax appending
399  (syntax-rules ()
400    ((appending args next . rest)
401     (accumulating (append-reverse reverse '()) args next . rest))))
402
403(define-syntax appending-reverse
404  (syntax-rules ()
405    ((appending-reverse args next . rest)
406     (accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
407
408(define-syntax summing
409  (syntax-rules ()
410    ((summing args next . rest)
411     (accumulating (+ (lambda (x) x) 0) args next . rest))))
412
413(define-syntax multiplying
414  (syntax-rules ()
415    ((multiplying args next . rest)
416     (accumulating (* (lambda (x) x) 1) args next . rest))))
417
418(define-syntax in-hash-table
419  (syntax-rules ()
420    ((in-hash-table ((key) (table)) next . rest)
421     (in-hash-table ((key _) (table)) next . rest))
422    ((in-hash-table ((key val) (table)) next . rest)
423     (next ((tmp-vec (##sys#slot table 1))
424            (end (vector-length tmp-vec))
425            (next-pair-bucket
426             (lambda (start)
427               (let lp ((i start))
428                 (and (< i end)
429                      (let ((x (vector-ref tmp-vec i)))
430                        (if (pair? x)
431                          i
432                          (lp (+ i 1))))))))
433            (first-bucket (next-pair-bucket 0)))
434           ((bucket first-bucket
435                    (if (and (pair? cell) (pair? (cdr cell)))
436                      bucket
437                      (next-pair-bucket (+ bucket 1))))
438            (cell (and first-bucket (vector-ref tmp-vec first-bucket))
439                  (if (and (pair? cell) (pair? (cdr cell)))
440                    (cdr cell)
441                    (let ((i (next-pair-bucket (+ bucket 1))))
442                      (and i (vector-ref tmp-vec i))))))
443           ((not bucket))
444           ((key (caar cell))
445            (val (cdar cell)))
446           ()
447       . rest))
448    ))
449
450)
Note: See TracBrowser for help on using the repository browser.