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

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

bug fixes in lexgen star

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