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

Last change on this file since 14868 was 14868, checked in by Ivan Raikov, 11 years ago

added lst combinator to lexgen

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