source: project/F-operator/bshift-breset.scm @ 2773

Last change on this file since 2773 was 2773, checked in by Kon Lovett, 14 years ago

Added nounwind -values routines.

File size: 5.0 KB
Line 
1;;;; bshift-breset.scm
2;;;; Kon Lovett, Apr 6 '06
3
4(cond-expand [hygienic-macros
5
6;; Statically scoped shift/reset (Oleg Kiselyov)
7
8(define-syntax %breset
9  (syntax-rules ()
10    [(_ RC BODY ...) (*%breset (lambda (RC) BODY ...) 'RC)]
11  ))
12
13(define-syntax %bshift
14  (syntax-rules ()
15    [(_ RC SP BODY ...) (*%bshift RC (lambda (SP) BODY ...) 'RC)]
16  ))
17
18(define-syntax breset
19  (syntax-rules ()
20    [(_ RC BODY ...) (*breset (lambda (RC) BODY ...) 'RC)]
21  ))
22
23(define-syntax bshift
24  (syntax-rules ()
25    [(_ RC SP BODY ...) (*bshift RC (lambda (SP) BODY ...) 'RC)]
26  ))
27
28(define-syntax %breset-values
29  (syntax-rules ()
30    [(_ RC BODY ...) (*%breset-values (lambda (RC) BODY ...) 'RC)]
31  ))
32
33(define-syntax %bshift-values
34  (syntax-rules ()
35    [(_ RC SP BODY ...) (*%bshift-values RC (lambda (SP) BODY ...) 'RC)]
36  ))
37
38(define-syntax breset-values
39  (syntax-rules ()
40    [(_ RC BODY ...) (*breset-values (lambda (RC) BODY ...) 'RC)]
41  ))
42
43(define-syntax bshift-values
44  (syntax-rules ()
45    [(_ RC SP BODY ...) (*bshift-values RC (lambda (SP) BODY ...) 'RC)]
46  ))
47
48;; Range (Oleg Kiselyov)
49
50(define-syntax range-empty?
51  (syntax-rules ()
52    [(_ RV) (eq? *range:empty* RV)]
53  ))
54
55(define-syntax range
56  (syntax-rules ()
57
58    [(_ RC FROM VALUE STEP TO?)
59      (bshift RC shifter
60        (let loop ([state (FROM)])
61          (if (TO? state)
62            *range:empty*
63            (begin
64              (shifter (VALUE state))
65              (loop (STEP state))))))]
66
67      ; number range
68    [(_ RC FROM STEP TO)
69      (bshift RC shifter
70        (do ([i FROM (+ i STEP)])
71            ((> i TO) *range:empty*)
72          (shifter i)))]
73
74    [(_ RC FROM TO)
75      (range RC FROM 1 TO)]
76  ))
77
78(define-syntax %range
79  (syntax-rules ()
80
81    [(_ RC FROM VALUE STEP TO?)
82      (%bshift RC shifter
83        (let loop ([state (FROM)])
84          (if (TO? state)
85            *range:empty*
86            (begin
87              (shifter (VALUE state))
88              (loop (STEP state))))))]
89
90      ; number range
91    [(_ RC FROM STEP TO)
92      (%bshift RC shifter
93        (do ([i FROM (+ i STEP)])
94            ((> i TO) *range:empty*)
95          (shifter i)))]
96
97    [(_ RC FROM TO)
98      (%range RC FROM 1 TO)]
99  ))
100
101][else
102
103;;; Statically scoped shift/reset (Oleg Kiselyov)
104
105(define-macro (breset RC . BODY)
106  `(*breset (lambda (,RC) ,@BODY) ',RC) )
107
108(define-macro (bshift RC SP . BODY)
109  `(*bshift ,RC (lambda (,SP) ,@BODY) ',RC) )
110
111(define-macro (breset-values RC . BODY)
112  `(*breset-values (lambda (,RC) ,@BODY) ',RC) )
113
114(define-macro (bshift-values RC SP . BODY)
115  `(*bshift-values ,RC (lambda (,SP) ,@BODY) ',RC) )
116
117(define-macro (%breset RC . BODY)
118  `(*%breset (lambda (,RC) ,@BODY) ',RC) )
119
120(define-macro (%bshift RC SP . BODY)
121  `(*%bshift ,RC (lambda (,SP) ,@BODY) ',RC) )
122
123(define-macro (%breset-values RC . BODY)
124  `(*%breset-values (lambda (,RC) ,@BODY) ',RC) )
125
126(define-macro (%bshift-values RC SP . BODY)
127  `(*%bshift-values ,RC (lambda (,SP) ,@BODY) ',RC) )
128
129;;; Range (Oleg Kiselyov)
130
131(define-macro (range-empty? RV)
132  `(eq? *range:empty* ,RV) )
133
134(define-macro (range RC FROM . REST)
135  (let ([arglen (length REST)])
136    (cond
137      [(= arglen 3)
138        (let ([VALUE (car REST)] [STEP (cadr REST)] [TO? (caddr REST)]
139              [LOOP-VAR (gensym)] [STATE-VAR (gensym)] [SHIFTER-VAR (gensym)])
140          `(bshift ,RC ,SHIFTER-VAR
141            (let ,LOOP-VAR ([,STATE-VAR (,FROM)])
142              (if (,TO? ,STATE-VAR)
143                *range:empty*
144                (begin
145                  (,SHIFTER-VAR (,VALUE ,STATE-VAR))
146                  (,LOOP-VAR (,STEP ,STATE-VAR)) ) ) )) )]
147      [(= arglen 2)
148        (let ([STEP (car REST)] [TO (cadr REST)]
149              [LOOP-VAR (gensym)] [I-VAR (gensym)] [SHIFTER-VAR (gensym)])
150          `(bshift ,RC ,SHIFTER-VAR
151            (do ([,I-VAR ,FROM (+ ,I-VAR ,STEP)])
152                ((> ,I-VAR ,TO) *range:empty*)
153              (,SHIFTER-VAR ,I-VAR) )) )]
154      [(= arglen 1)
155        (let ([TO (car REST)])
156          `(range ,RC ,FROM 1 ,TO) )]
157      [else
158        (syntax-error 'range "wrong number of arguments" REST)] ) ) )
159
160(define-macro (%range RC FROM . REST)
161  (let ([arglen (length REST)])
162    (cond
163      [(= arglen 3)
164        (let ([VALUE (car REST)] [STEP (cadr REST)] [TO? (caddr REST)]
165              [LOOP-VAR (gensym)] [STATE-VAR (gensym)] [SHIFTER-VAR (gensym)])
166          `(%bshift ,RC ,SHIFTER-VAR
167            (let ,LOOP-VAR ([,STATE-VAR (,FROM)])
168              (if (,TO? ,STATE-VAR)
169                *range:empty*
170                (begin
171                  (,SHIFTER-VAR (,VALUE ,STATE-VAR))
172                  (,LOOP-VAR (,STEP ,STATE-VAR)) ) ) )) )]
173      [(= arglen 2)
174        (let ([STEP (car REST)] [TO (cadr REST)]
175              [LOOP-VAR (gensym)] [I-VAR (gensym)] [SHIFTER-VAR (gensym)])
176          `(%bshift ,RC ,SHIFTER-VAR
177            (do ([,I-VAR ,FROM (+ ,I-VAR ,STEP)])
178                ((> ,I-VAR ,TO) *range:empty*)
179              (,SHIFTER-VAR ,I-VAR) )) )]
180      [(= arglen 1)
181        (let ([TO (car REST)])
182          `(%range ,RC ,FROM 1 ,TO) )]
183      [else
184        (syntax-error '%range "wrong number of arguments" REST)] ) ) )
185
186])
Note: See TracBrowser for help on using the repository browser.