Changeset 14322 in project


Ignore:
Timestamp:
04/21/09 06:28:39 (11 years ago)
Author:
Alex Shinn
Message:

adding accumulators, hash-table support, while/until

Location:
release/4/fast-loop/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/fast-loop/trunk/fast-loop.meta

    r14270 r14322  
    22 (synopsis "Fast extensible looping macros")
    33 (egg "fast-loop.egg")
    4  (files "fast-loop.scm" "fast-loop.html" "fast-loop.setup")
     4 (files "fast-loop.scm" "fast-loop.setup")
    55 (license "BSD")
    66 (doc-from-wiki)
  • release/4/fast-loop/trunk/fast-loop.scm

    r14270 r14322  
    1010;; Unsafe operations have been inlined where they can be proven safe.
    1111
    12 (require-extension matchable)
     12(require-extension matchable srfi-1)
    1313
    1414(module fast-loop
    1515 (loop in-list in-lists in-vector in-vector-reverse
    1616  in-string in-string-reverse in-port in-file
    17   listing
     17  in-hash-table up-from down-from
     18  listing listing-reverse
     19  (appending append-reverse) (appending-reverse append-reverse)
    1820  define-in-indexed)
    1921
    20 (import scheme chicken matchable)
     22(import scheme chicken matchable srfi-1)
    2123
    2224;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    132134    ((_ name l (vars ...) c r f ((with var init) rest ...) . body)
    133135     (%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))
    134141    ;; specify a default done?
    135142    ((_ name l v c r f ())
     
    313320       . rest))))
    314321
     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
    315388(define-syntax listing
    316389  (syntax-rules ()
    317     ((listing ((var) source) next . rest)
    318      (listing ((var cursor) source) next . rest))
    319     ((listing ((var cursor) (source)) next . rest)
    320      (listing ((var cursor) (source cons)) next . rest))
    321     ((listing ((var cursor) (source kons)) next . rest)
    322      (listing ((var cursor) (source kons reverse)) next . rest))
    323     ((listing ((var cursor) (source kons final)) next . rest)
    324      (next ((tmp-kons kons))
    325            ((cursor '() (tmp-kons source cursor)))
    326            ()
    327            ()
    328            ((var (final cursor)))
    329        . rest))))
     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    ))
    330449
    331450)
  • release/4/fast-loop/trunk/fast-loop.setup

    r14270 r14322  
    55 'fast-loop
    66 '("fast-loop.so" "fast-loop.import.so")
    7  '((version 0.1)))
     7 '((version 0.2)))
    88
  • release/4/fast-loop/trunk/test.scm

    r14270 r14322  
    3232 '(a b c)
    3333 (loop ((for x (in-list '(a b c))) (for res (listing x))) => res))
     34
     35(test
     36 "in-list with listing-reverse"
     37 '(c b a)
     38 (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res))
    3439
    3540(test
     
    9196 (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res))
    9297
     98(test "up-from" '(5 6 7)
     99  (loop ((for i (up-from 5 (to 8)))
     100         (for res (listing i)))
     101    => res))
     102
     103(test "up-from by" '(5 10 15)
     104  (loop ((for i (up-from 5 (to 20) (by 5)))
     105         (for res (listing i)))
     106    => res))
     107
     108(test "up-from listing if" '(10 12 14 16 18)
     109  (loop ((for i (up-from 10 (to 20)))
     110         (for res (listing i (if (even? i)))))
     111    => res))
     112
     113(test "down-from" '(7 6 5)
     114  (loop ((for i (down-from 8 (to 5)))
     115         (for res (listing i)))
     116    => res))
     117
     118(test "down-from by" '(15 10 5)
     119  (loop ((for i (down-from 20 (to 5) (by 5)))
     120         (for res (listing i)))
     121    => res))
     122
     123(test "down-from listing if" '(18 16 14 12 10)
     124  (loop ((for i (down-from 20 (to 10)))
     125         (for res (listing i (if (even? i)))))
     126    => res))
     127
     128(test "appending" '(1 2 3 4 5 6 7 8 9)
     129  (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
     130         (for res (appending ls)))
     131    => res))
     132
     133(test "appending-reverse" '(9 8 7 6 5 4 3 2 1)
     134  (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
     135         (for res (appending-reverse ls)))
     136    => res))
     137
    93138(test-end)
    94139
Note: See TracChangeset for help on using the changeset viewer.