source: project/release/4/lexgen/trunk/tests/run.scm @ 18280

Last change on this file since 18280 was 18280, checked in by Ivan Raikov, 10 years ago

initial import of signal-diagram

File size: 8.2 KB
Line 
1
2(require-extension chicken lexgen srfi-1 srfi-14 test)
3
4
5(define a-pat (tok #\a (try char=?)))
6(define b-pat (tok #\b (try char=?)))
7(define a-then-b-pat (seq a-pat b-pat))
8(define a-or-b-pat (bar a-pat b-pat))
9(define redo-b-a-pat (redo b-pat a-pat pass))
10(define a-star-pat (star a-pat))
11(define a-star*-pat (star* a-pat))
12(define a-star-or-b-pat (bar (star a-pat) b-pat))
13(define a-or-b-star-pat (star a-or-b-pat))
14(define a-b-opt-pat (seq a-pat (opt b-pat)))
15(define b-opt-a-pat (seq (opt b-pat) a-pat))
16(define a-b-opt-a-pat (seq a-pat (seq (opt b-pat) a-pat)))
17(define a-star-b-opt-pat (seq (star a-pat) (opt b-pat)))
18(define aabac-pat (lit "aabac"))
19(define aa-pat (lit "aa"))
20(define n4-pat (lst (list-tabulate 4 (lambda (i) (range #\0 #\9)))))
21
22(define abc-stream      (list `(() ,(string->list "abc"))))
23(define bac-stream      (list `(() ,(string->list "bac"))))
24(define aabac-stream    (list `(() ,(string->list "aabac"))))
25(define aaaabac-stream  (list `(() ,(string->list "aaaabac"))))
26(define num-stream      (list `(() ,(string->list "1234"))))
27
28(define (err s)
29  (print "lexical error on stream: " s)
30  (list))
31
32(test-group "lexgen test"
33            (test (sprintf "match [a] on ~S" "abc") 
34                   `(((#\a) (#\b #\c))) (a-pat identity abc-stream))
35
36            (test (sprintf "match [b] on ~S" "abc") 
37                   `() (b-pat identity abc-stream))
38
39            (test (sprintf "match redo [b] [a] on ~S" "abc") 
40                   `(((#\a) (#\b #\c)))  (redo-b-a-pat identity abc-stream))
41
42            (test (sprintf "match ab on ~S" "abc") 
43                   `(((#\b #\a ) ( #\c))) 
44                   (a-then-b-pat identity abc-stream))
45
46            (test (sprintf "match a|b on ~S" "abc") 
47                   `(((#\a) (#\b #\c))) 
48                   (a-or-b-pat identity abc-stream))
49
50            (test (sprintf "match a|b on ~S" "bac") 
51                   `(((#\b) (#\a #\c))) 
52                   (a-or-b-pat identity bac-stream))
53
54            (test (sprintf "match a* on ~S" "abc") 
55                   `((() (#\a #\b #\c)) ((#\a) (#\b #\c))) 
56                   (a-star-pat identity abc-stream))
57
58            (test (sprintf "match greedy a* on ~S" "abc") 
59                   `((() (#\a #\b #\c)) ((#\a) (#\b #\c))) 
60                   (a-star-pat identity abc-stream))
61
62            (test (sprintf "match a* on ~S" "aabac") 
63                  `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
64                  (a-star-pat identity  aabac-stream))
65
66            (test (sprintf "match greedy a* on ~S" "aabac") 
67                  `(((#\a #\a) (#\b #\a #\c)))
68                  (a-star*-pat identity aabac-stream))
69
70            (test (sprintf "match (a*|b) on ~S" "aabac") 
71                   `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
72                   (a-star-or-b-pat identity  aabac-stream))
73
74            (test (sprintf "match (a|b)* on ~S" "abc") 
75                   `((() (#\a #\b #\c))  ((#\a) (#\b #\c)) ((#\b #\a) (#\c)))
76                   (a-or-b-star-pat identity  abc-stream))
77
78            (test (sprintf "match (a|b)* on ~S" "aabac") 
79                   `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)) 
80                     ((#\b #\a #\a) (#\a #\c)) ((#\a #\b #\a #\a) (#\c)))
81                   (a-or-b-star-pat identity  aabac-stream))
82
83            (test (sprintf "match ab? on ~S" "abc") 
84                   `(((#\b #\a) (#\c)) )
85                   (a-b-opt-pat identity  abc-stream))
86
87            (test (sprintf "match ab? on ~S" "aabac") 
88                   `(((#\a) (#\a #\b #\a #\c)) )
89                   (a-b-opt-pat identity  aabac-stream))
90
91            (test (sprintf "match b?a on ~S" "abc") 
92                   `(((#\a) (#\b #\c)) )
93                   (b-opt-a-pat identity  abc-stream))
94
95            (test (sprintf "match ab?a on ~S" "aabac") 
96                   `(((#\a #\a) (#\b #\a #\c)) )
97                   (a-b-opt-a-pat identity  aabac-stream))
98
99            (test (sprintf "match a*b? on ~S" "aabac") 
100                   `(((#\b #\a #\a) (#\a #\c)))
101                   (a-star-b-opt-pat identity aabac-stream))
102
103            (test (sprintf "match literal string ~S" "aabac") 
104                   `(((#\c #\a #\b #\a #\a) ()) )
105                   (aabac-pat identity aabac-stream))
106
107            (test (sprintf "match n4 on  ~S" "1234") 
108                   `(((#\4 #\3 #\2 #\1) ()) )
109                   (n4-pat identity num-stream))
110
111            )
112
113
114;; A pattern to match floating point numbers.
115;; "-"?(([0-9]+(\\.[0-9]+)?)|(\\.[0-9]+))([eE][+-]?[0-9]+)?
116
117(define numpat
118  (let* ((digit        (range #\0 #\9))
119         (digits       (pos digit))
120         (fraction     (seq (char #\.) digits))
121         (significand  (bar (seq digits (opt fraction)) fraction))
122         (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
123         (sign         (opt (char #\-))))
124    (seq sign (seq significand (opt exp)))))
125
126(test-group "lexgen numpat test"
127            (test (sprintf "match numpat on ~S" "-123.45e-6")
128                   `((#\- #\1 #\2 #\3 #\. #\4 #\5 #\e #\- #\6) ()) 
129                   (lex numpat err "-123.45e-6"))
130            (test (sprintf "match numpat on ~S" "hi there")
131                  #f (lex numpat err "hi there")))
132
133(define (->char-list s)
134  (if (string? s) (string->list s) s))
135
136(define (collect cs) 
137  (let loop ((cs cs) (ax (list)))
138    (cond ((null? cs)         `(,(list->string ax)))
139          ((atom? (car cs))   (loop (cdr cs) (cons (car cs) ax)))
140          (else               (cons (list->string ax) cs)))))
141
142(define (make-exp x)
143  (or (and (pair? x) 
144           (let ((x1 (collect x)))
145             (list `(exp . ,x1)))) x))
146
147(define (make-significand x)
148  (or (and (pair? x) 
149           (let ((x1 (collect x)))
150             (cons `(significand ,(car x1)) (cdr x1)))) x))
151
152(define (make-sign x)
153  (or (and (pair? x) 
154           (let ((x1 (collect x)))
155             (cons `(sign ,(car x1)) (cdr x1)))) x))
156
157(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))
158
159(define bnumpat 
160  (let* ((digit        (range #\0 #\9))
161         (digits       (star digit))
162         (fraction     (seq (char #\.) digits))
163         (significand  (bar (seq digits (opt fraction)) fraction))
164         (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
165         (sign         (opt (char #\-)) )
166         (pat          (seq (bind make-sign sign) 
167                            (seq (bind make-significand (longest significand))
168                                 (bind make-exp (longest (opt exp)))))))
169    pat))
170
171(define (num-parser s) (car (lex bnumpat err s)))
172
173
174(test-group "lexgen num-parser test"
175            (test (sprintf "match num-parser on ~S" "-123.45e-6")
176                   `((sign "-") (significand "123.45") (exp "e-6"))
177                   (num-parser "-123.45e-6"))
178            )
179
180
181;; Tokens with position information
182
183(define-record-type postok
184  (make-postok pos token)
185  postok?
186  (pos        postok-pos )
187  (token      postok-token )
188  )
189
190(define-record-printer (postok x out)
191  (fprintf out "#<token ~A: ~A>" 
192           (postok-pos x)
193           (postok-token x)))
194
195(define pos? pair?)
196(define pos-row car)
197(define pos-col cdr)
198(define make-pos cons)
199
200(define-record-type  stream-pos (stream-pos c rest)
201  stream-pos? 
202  (c stream-pos-c)
203  (rest stream-pos-rest ))
204
205;; Converts an input stream to a stream with position information:
206
207(define (make-stream-pos begtok)
208  (and (postok? begtok)
209       (stream-unfold 
210        begtok
211        (lambda (begtok strm) 
212(print "begtok = " begtok)
213(print "strm = " strm)
214 
215          (if (null? strm) 
216              '()
217              (let* ((pos0 (postok-pos begtok))
218                     (pos1 (let ((row0 (pos-row pos0))
219                                 (col0 (pos-col pos0)))
220                             (case (car strm)
221                               ((#\newline)  (make-pos (+ 1 row0) 1))
222                               ((#\return)   (make-pos row0 1))
223                               (else         (make-pos row0 (+ 1 col0))))))
224                     (res (stream-pos (make-postok pos1 (car strm)) (cdr strm))))
225                res)))
226        postok-token)))
227
228(define begpos (make-pos 1 0))
229
230(define (getpos p)
231  (let ((f (lambda (in) (print "in = " in)
232                   (print "stream-pos-c (cdr in) = " (stream-pos-c (cdr in)))
233                   (and (pair? in) (stream-pos? (cdr in)) 
234                        (postok-pos (stream-pos-c (cdr in))))))
235        (g (lambda (i s) (print "i = " i)
236                   (print "s = " s)
237                   (list (make-postok i (car s))))))
238    (rebind f g p)))
239
240(define pos-numpat-stream
241  (list ((make-stream-pos (make-postok begpos 'start))
242         `(() ,(string->list "-123.45e-6")))))
243
244(define pbnumpat 
245  (let* ((digit        (range #\0 #\9))
246         (digits       (star digit))
247         (fraction     (seq (char #\.) digits))
248         (significand  (bar (seq digits (opt fraction)) fraction))
249         (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
250         (sign         (opt (char #\-)) )
251         (pat          (seq (getpos (bind make-sign sign))
252                            (seq (getpos (bind make-significand (longest significand)))
253                                 (getpos (bind make-exp (longest (opt exp))))))))
254    pat))
255
256(define (pos-num-parser s) (car (lex pbnumpat err s)))
257
258(pos-num-parser pos-numpat-stream)
259
260(test-group "lexgen pos-num-parser test"
261            (test (sprintf "match pos-num-parser on ~S" "-123.45e-6")
262                   `(,(make-postok (make-pos 1 1) `(sign "-"))
263                     ,(make-postok (make-pos 1 2) `(significand "123.45"))
264                     ,(make-postok (make-pos 1 8) `(exp "e-6")))
265                   (pos-num-parser pos-numpat-stream))
266            )
Note: See TracBrowser for help on using the repository browser.