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

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

cps variant of lexgen

File size: 4.5 KB
Line 
1
2(require-extension chicken lexgen srfi-1 srfi-14 matchable 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 a-star-pat (star a-pat))
10(define a-star-or-b-pat (bar (star a-pat) b-pat))
11(define a-or-b-star-pat (star a-or-b-pat))
12(define a-b-opt-pat (seq a-pat (opt b-pat)))
13(define a-star-b-opt-pat (seq (star a-pat) (opt b-pat)))
14 
15(define abc-stream (list `(() ,(string->list "abc"))))
16(define bac-stream (list `(() ,(string->list "bac"))))
17(define aabac-stream (list `(() ,(string->list "aabac"))))
18
19(define (err s)
20  (print "lexical error on stream: " s)
21  (list))
22
23(test-group "lexgen test"
24            (test (sprintf "match [a] on ~S" "abc") 
25                   `(((#\a) (#\b #\c))) (a-pat identity err abc-stream))
26
27            (test (sprintf "match [b] on ~S" "abc") 
28                   `() (b-pat identity err abc-stream))
29
30            (test (sprintf "match ab on ~S" "abc") 
31                   `(((#\b #\a ) ( #\c))) 
32                   (a-then-b-pat identity err abc-stream))
33
34            (test (sprintf "match a|b on ~S" "abc") 
35                   `(((#\a) (#\b #\c))) 
36                   (a-or-b-pat identity err abc-stream))
37
38            (test (sprintf "match a|b on ~S" "bac") 
39                   `(((#\b) (#\a #\c))) 
40                   (a-or-b-pat identity err bac-stream))
41
42            (test (sprintf "match a* on ~S" "abc") 
43                   `((() (#\a #\b #\c)) ((#\a) (#\b #\c))) 
44                   (a-star-pat identity err abc-stream))
45
46            (test (sprintf "match a* on ~S" "aabac") 
47                  `((() (#\a #\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
48                  (a-star-pat identity err aabac-stream))
49
50            (test (sprintf "match (a*|b) on ~S" "aabac") 
51                   `((() (#\a #\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
52                   (a-star-or-b-pat identity err aabac-stream))
53
54            (test (sprintf "match (a|b)* on ~S" "abc") 
55                   `((() (#\a #\b #\c))  ((#\b #\a) (#\c)))
56                   (a-or-b-star-pat identity err abc-stream))
57
58            (test (sprintf "match (a|b)* on ~S" "aabac") 
59                   `((() (#\a #\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)) ((#\b #\a #\a) (#\a #\c)))
60                   (a-or-b-star-pat identity err aabac-stream))
61
62            (test (sprintf "match ab? on ~S" "aabac") 
63                   `(((#\a) (#\a #\b #\a #\c)) )
64                   (a-b-opt-pat identity err aabac-stream))
65
66            (test (sprintf "match ab? on ~S" "abc") 
67                   `(((#\b #\a) (#\c)) )
68                   (a-b-opt-pat identity err abc-stream))
69
70            (test (sprintf "match a*b? on ~S" "aabac") 
71                   `(((#\b #\a #\a) (#\a #\c)) )
72                   (a-star-b-opt-pat identity err aabac-stream))
73
74            )
75
76;; A pattern to match floating point numbers.
77;; "-"?(([0-9]+(\\.[0-9]+)?)|(\\.[0-9]+))([eE][+-]?[0-9]+)?
78
79(define numpat
80  (let* ((digit        (range #\0 #\9))
81         (digits       (pos digit))
82         (fraction     (seq (char #\.) digits))
83         (significand  (bar (seq digits (opt fraction)) fraction))
84         (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
85         (sign         (opt (char #\-))))
86    (seq sign (seq significand (opt exp)))))
87
88
89(test-group "lexgen numpat test"
90            (test (sprintf "match numpat on ~S" "-3.45e-6")
91                   `((#\- #\3 #\. #\4 #\5 #\e #\- #\6) ()) (lex numpat err "-3.45e-6"))
92            (test (sprintf "match numpat on ~S" "hi there")
93                  #f (lex numpat err "hi there")))
94
95(define (->char-list s)
96  (if (string? s) (string->list s) s))
97
98(define (bind f p)
99  (lambda (a r s)
100    (let ((a1 (lambda (s1) 
101                (match (longest s1)
102                       ((eaten food) 
103                        (let ((x (f eaten)))
104                          (a `((,x ,food)))))
105                       (else #f)))))
106      (p a1 r s))))
107           
108(define ($ cs) 
109  (let loop ((cs cs) (ax (list)))
110    (cond ((null? cs)         `(,(list->string ax)))
111          ((atom? (car cs))   (loop (cdr cs) (cons (car cs) ax)))
112          (else               (cons (list->string ax) cs)))))
113
114(define (make-exp x)
115  (or (and (pair? x) (let ((x1 ($ x)))
116                       (cons `(exp ,(car x1)) (cdr x1)))) x))
117
118(define (make-significand x)
119  (or (and (pair? x) (let ((x1 ($ x)))
120                       (cons `(significand ,(car x1)) (cdr x1)))) x))
121
122(define (make-sign x)
123  (or (and (pair? x) (let ((x1 ($ x)))
124                       (cons `(sign ,(car x1)) (cdr x1)))) x))
125
126
127(define (num-parser s)
128  (let* ((digit        (range #\0 #\9))
129         (digits       (star digit))
130         (fraction     (seq (char #\.) digits))
131         (significand  (bar (seq digits (opt fraction)) fraction))
132         (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
133         (sign         (opt (char #\-)) )
134         (pat          (seq (bind make-sign sign) (seq (bind make-significand significand) (bind make-exp (opt exp))))))
135    (reverse (car (longest (pat identity err `((() ,(->char-list s)))))))))
136
137
138(test-group "lexgen num-parser test"
139            (test (sprintf "match num-parser on ~S" "-3.45e-6")
140                   `((sign "-") (significand "3.45") (exp "e-6"))
141                   (num-parser "-3.45e-6"))
142            )
Note: See TracBrowser for help on using the repository browser.