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

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

added cps-table in lexgen

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