source: project/release/3/F-operator/range.scm @ 8904

Last change on this file since 8904 was 8904, checked in by Kon Lovett, 12 years ago

Save.

File size: 3.7 KB
Line 
1;;;; range.scm
2;;;; Kon Lovett, Apr 6 '06
3
4(use bshift-breset)
5
6(cond-expand
7  [hygienic-macros
8
9    ;; Range (Oleg Kiselyov)
10
11    (define-syntax range-empty?
12      (syntax-rules ()
13        [(_ RV) (eq? *range:empty* RV)] ) )
14
15    (define-syntax range
16      (syntax-rules ()
17
18        [(_ RC FROM VALUE STEP TO?)
19          (bshift RC shifter
20            (let loop ([state (FROM)])
21              (if (TO? state)
22                *range:empty*
23                (begin
24                  (shifter (VALUE state))
25                  (loop (STEP state))))))]
26
27          ; number range
28        [(_ RC FROM STEP TO)
29          (bshift RC shifter
30            (do ([i FROM (+ i STEP)])
31                ((> i TO) *range:empty*)
32              (shifter i)))]
33
34        [(_ RC FROM TO)
35          (range RC FROM 1 TO)] ) )
36
37    (define-syntax %range
38      (syntax-rules ()
39
40        [(_ RC FROM VALUE STEP TO?)
41          (%bshift RC shifter
42            (let loop ([state (FROM)])
43              (if (TO? state)
44                *range:empty*
45                (begin
46                  (shifter (VALUE state))
47                  (loop (STEP state))))))]
48
49          ; number range
50        [(_ RC FROM STEP TO)
51          (%bshift RC shifter
52            (do ([i FROM (+ i STEP)])
53                ((> i TO) *range:empty*)
54              (shifter i)))]
55
56        [(_ RC FROM TO)
57          (%range RC FROM 1 TO)] ) ) ]
58  [else
59
60    ;;; Range (Oleg Kiselyov)
61
62    (define-macro (range-empty? RV)
63      `(eq? *range:empty* ,RV) )
64
65    (define-macro (range RC FROM . REST)
66      (let ([arglen (length REST)])
67        (cond
68          [(= arglen 3)
69            (let ([VALUE (car REST)] [STEP (cadr REST)] [TO? (caddr REST)]
70                  [LOOP-VAR (gensym)] [STATE-VAR (gensym)] [SHIFTER-VAR (gensym)])
71              `(bshift ,RC ,SHIFTER-VAR
72                (let ,LOOP-VAR ([,STATE-VAR (,FROM)])
73                  (if (,TO? ,STATE-VAR)
74                    *range:empty*
75                    (begin
76                      (,SHIFTER-VAR (,VALUE ,STATE-VAR))
77                      (,LOOP-VAR (,STEP ,STATE-VAR)) ) ) )) )]
78          [(= arglen 2)
79            (let ([STEP (car REST)] [TO (cadr REST)]
80                  [LOOP-VAR (gensym)] [I-VAR (gensym)] [SHIFTER-VAR (gensym)])
81              `(bshift ,RC ,SHIFTER-VAR
82                (do ([,I-VAR ,FROM (+ ,I-VAR ,STEP)])
83                    ((> ,I-VAR ,TO) *range:empty*)
84                  (,SHIFTER-VAR ,I-VAR) )) )]
85          [(= arglen 1)
86            (let ([TO (car REST)])
87              `(range ,RC ,FROM 1 ,TO) )]
88          [else
89            (syntax-error 'range "wrong number of arguments" REST)] ) ) )
90
91    (define-macro (%range RC FROM . REST)
92      (let ([arglen (length REST)])
93        (cond
94          [(= arglen 3)
95            (let ([VALUE (car REST)] [STEP (cadr REST)] [TO? (caddr REST)]
96                  [LOOP-VAR (gensym)] [STATE-VAR (gensym)] [SHIFTER-VAR (gensym)])
97              `(%bshift ,RC ,SHIFTER-VAR
98                (let ,LOOP-VAR ([,STATE-VAR (,FROM)])
99                  (if (,TO? ,STATE-VAR)
100                    *range:empty*
101                    (begin
102                      (,SHIFTER-VAR (,VALUE ,STATE-VAR))
103                      (,LOOP-VAR (,STEP ,STATE-VAR)) ) ) )) )]
104          [(= arglen 2)
105            (let ([STEP (car REST)] [TO (cadr REST)]
106                  [LOOP-VAR (gensym)] [I-VAR (gensym)] [SHIFTER-VAR (gensym)])
107              `(%bshift ,RC ,SHIFTER-VAR
108                (do ([,I-VAR ,FROM (+ ,I-VAR ,STEP)])
109                    ((> ,I-VAR ,TO) *range:empty*)
110                  (,SHIFTER-VAR ,I-VAR) )) )]
111          [(= arglen 1)
112            (let ([TO (car REST)])
113              `(%range ,RC ,FROM 1 ,TO) )]
114          [else
115            (syntax-error '%range "wrong number of arguments" REST)] ) ) ) ] )
Note: See TracBrowser for help on using the repository browser.