Changeset 14885 in project
- Timestamp:
- 06/05/09 04:44:43 (12 years ago)
- Location:
- release/4/lexgen/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/lexgen/trunk/lexgen.scm
r14871 r14885 44 44 try pass pos opt char 45 45 set range lst lit 46 longest lex ) 47 48 49 (import scheme chicken data-structures srfi-14) 50 (require-extension srfi-1 matchable) 46 cps-table longest lex ) 47 48 49 (import scheme chicken data-structures 50 (only srfi-1 first second filter-map fold concatenate) 51 srfi-14 srfi-69) 52 (require-extension matchable) 51 53 52 54 ;; … … 75 77 (define (tok t p) 76 78 (let ((f (lambda (s) 77 (match s ((c (h . r)) 78 (let ((ans (p t h))) 79 (and ans (list (cons ans c) r)))) 80 ((c ()) s) 79 (match s 80 ((c (h . r)) 81 (let ((ans (p t h))) 82 (and ans (list (cons ans c) r)))) 83 ((c ()) s) 81 84 (else #f))))) 82 (lambda ( a rstreams)85 (lambda (cont streams) 83 86 (let ((streams1 (filter-map f streams))) 84 ( if (null? streams1) (r streams) (a streams1))))))87 (cont streams1))))) 85 88 86 89 … … 88 91 89 92 (define (seq p1 p2) 90 (lambda ( a rstreams)91 (p1 (lambda (streams1) (p2 a r streams1)) rstreams)))93 (lambda (cont streams) 94 (p1 (lambda (streams1) (p2 cont streams1)) streams))) 92 95 93 96 … … 96 99 97 100 (define (bar p1 p2) 98 (lambda (a r streams) 99 (let ((r1 (lambda (streams1) (p2 a (lambda (streams2) (r streams1)) streams)) )) 100 (p1 a r1 streams)))) 101 (lambda (cont streams) 102 (let ((cont1 (lambda (streams1) 103 (if (null? streams1) (p2 cont streams) (cont streams1))))) 104 (p1 cont1 streams)))) 101 105 102 106 … … 104 108 105 109 (define (star p) 106 (lambda (a r streams) 107 (let ((a1 (lambda (streams1) (a (concatenate (list streams streams1)))))) 108 (p (lambda (streams1) (if (equal? streams streams1) (a streams1) 109 ((star p) a1 a1 streams1))) 110 a streams)))) 110 (lambda (cont streams) 111 (if (null? streams) (cont streams) 112 (let ((cont1 (lambda (streams1) (cont (concatenate (list streams streams1)))))) 113 (p (lambda (streams1) 114 (cond ((equal? streams streams1) (cont streams)) 115 (else ((star p) cont1 streams1)))) 116 streams))))) 111 117 112 118 ;; The rest of these are built from the previous four and are provided … … 114 120 115 121 ;; this parser always succeeds 116 (define (pass a r s) (as))122 (define (pass cont s) (cont s)) 117 123 118 124 ;; Positive closure. Analogous to '+' … … 189 195 (define (lex pat error s) 190 196 (let* ((stream (->char-list s)) 191 (res (longest (pat identity error`((() ,stream))))))197 (res (longest (pat (lambda (s1) (if (null? s1) (error s) s1)) `((() ,stream)))))) 192 198 (and res (list (reverse (first res)) (second res))))) 193 199 200 201 (define make-table make-hash-table) 202 (define table-ref hash-table-ref/default) 203 (define table-put! hash-table-set!) 204 (define table-for-each hash-table-for-each) 205 206 207 ;; tabled execution wrapper 208 ;; from _Tabled Execution in Scheme_, by Willcock, et al. 209 210 (define (cps-table f combine) 211 (let ((memo (make-table equal?)) 212 (k-list (make-table equal?))) 213 (lambda (k arg) 214 (table-put! k-list arg (cons k (table-ref k-list arg (list)))) 215 (if (not (table-ref memo arg #f)) 216 (let ((memo-table (make-table))) 217 (print "miss: arg = " arg) 218 (table-put! memo arg memo-table) 219 (f (lambda (result) 220 (print "miss: result = " result) 221 (if (null? result) (k result) 222 (let* ((len (length result)) 223 (old-len (table-ref memo-table result #f)) 224 (new-len (combine (or old-len 0) len))) 225 (print "len = " len) 226 (print "old-len = " old-len) 227 (print "new-len = " new-len) 228 (if (not (equal? old-len new-len)) 229 (begin 230 (table-put! memo-table result new-len) 231 (for-each (lambda (saved-k) (saved-k result)) 232 (table-ref k-list arg (list)))))))) 233 234 arg)) 235 (let ((memo-table (table-ref memo arg #f) )) 236 (print "hit: arg = " arg) 237 (table-for-each memo-table (lambda (result len) (k result))) 238 ))))) 239 194 240 ) -
release/4/lexgen/trunk/lexgen.setup
r14871 r14885 4 4 (make-pathname #f fn ##sys#load-dynamic-extension)) 5 5 6 (compile -O 2 -d0-s lexgen.scm -j lexgen)7 (compile - O2 -d0 -s lexgen.import.scm)6 (compile -O -d2 -s lexgen.scm -j lexgen) 7 (compile -s lexgen.import.scm) 8 8 9 9 (install-extension … … 17 17 18 18 ;; Assoc list with properties for your extension: 19 '((version 2. 2)19 '((version 2.3) 20 20 (documentation "lexgen.html") 21 21 )) -
release/4/lexgen/trunk/tests/run.scm
r14871 r14885 13 13 (define a-star-b-opt-pat (seq (star a-pat) (opt b-pat))) 14 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 <)))) 15 18 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 (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")))) 19 23 20 24 (define (err s) … … 24 28 (test-group "lexgen test" 25 29 (test (sprintf "match [a] on ~S" "abc") 26 `(((#\a) (#\b #\c))) (a-pat identity errabc-stream))30 `(((#\a) (#\b #\c))) (a-pat identity abc-stream)) 27 31 28 32 (test (sprintf "match [b] on ~S" "abc") 29 `() (b-pat identity errabc-stream))33 `() (b-pat identity abc-stream)) 30 34 31 35 (test (sprintf "match ab on ~S" "abc") 32 36 `(((#\b #\a ) ( #\c))) 33 (a-then-b-pat identity errabc-stream))37 (a-then-b-pat identity abc-stream)) 34 38 35 39 (test (sprintf "match a|b on ~S" "abc") 36 40 `(((#\a) (#\b #\c))) 37 (a-or-b-pat identity errabc-stream))41 (a-or-b-pat identity abc-stream)) 38 42 39 43 (test (sprintf "match a|b on ~S" "bac") 40 44 `(((#\b) (#\a #\c))) 41 (a-or-b-pat identity errbac-stream))45 (a-or-b-pat identity bac-stream)) 42 46 43 47 (test (sprintf "match a* on ~S" "abc") 44 48 `((() (#\a #\b #\c)) ((#\a) (#\b #\c))) 45 (a-star-pat identity errabc-stream))49 (a-star-pat identity abc-stream)) 46 50 47 51 (test (sprintf "match a* on ~S" "aabac") 48 52 `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c))) 49 (a-star-pat identity erraabac-stream))53 (a-star-pat identity aabac-stream)) 50 54 51 55 (test (sprintf "match (a*|b) on ~S" "aabac") 52 56 `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c))) 53 (a-star-or-b-pat identity erraabac-stream))57 (a-star-or-b-pat identity aabac-stream)) 54 58 55 59 (test (sprintf "match (a|b)* on ~S" "abc") 56 60 `((() (#\a #\b #\c)) ((#\a) (#\b #\c)) ((#\b #\a) (#\c))) 57 (a-or-b-star-pat identity errabc-stream))61 (a-or-b-star-pat identity abc-stream)) 58 62 59 63 (test (sprintf "match (a|b)* on ~S" "aabac") 60 64 `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)) 61 65 ((#\b #\a #\a) (#\a #\c)) ((#\a #\b #\a #\a) (#\c))) 62 (a-or-b-star-pat identity erraabac-stream))66 (a-or-b-star-pat identity aabac-stream)) 63 67 64 68 (test (sprintf "match ab? on ~S" "aabac") 65 69 `(((#\a) (#\a #\b #\a #\c)) ) 66 (a-b-opt-pat identity erraabac-stream))70 (a-b-opt-pat identity aabac-stream)) 67 71 68 72 (test (sprintf "match ab? on ~S" "abc") 69 73 `(((#\b #\a) (#\c)) ) 70 (a-b-opt-pat identity errabc-stream))74 (a-b-opt-pat identity abc-stream)) 71 75 72 76 (test (sprintf "match a*b? on ~S" "aabac") 73 77 `(((#\b #\a #\a) (#\a #\c)) ) 74 (a-star-b-opt-pat identity erraabac-stream))78 (a-star-b-opt-pat identity aabac-stream)) 75 79 76 80 (test (sprintf "match literal string ~S" "aabac") 77 81 `(((#\c #\a #\b #\a #\a) ()) ) 78 (aabac-pat identity err aabac-stream)) 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)) 79 89 80 90 ) 81 82 91 ;; A pattern to match floating point numbers. 83 92 ;; "-"?(([0-9]+(\\.[0-9]+)?)|(\\.[0-9]+))([eE][+-]?[0-9]+)? … … 98 107 (test (sprintf "match numpat on ~S" "hi there") 99 108 #f (lex numpat err "hi there"))) 100 101 109 (define (->char-list s) 102 110 (if (string? s) (string->list s) s)) 103 111 104 112 (define (bind f p) 105 (lambda ( a rs)106 (let (( a1 (lambda (s1)113 (lambda (cont s) 114 (let ((cont1 (lambda (s1) 107 115 (match (longest s1) 108 116 ((eaten food) 109 117 (let ((x (f eaten))) 110 ( a`((,x ,food)))))118 (cont `((,x ,food))))) 111 119 (else #f))))) 112 (p a1 rs))))120 (p cont1 s)))) 113 121 114 122 (define ($ cs) … … 130 138 (cons `(sign ,(car x1)) (cdr x1)))) x)) 131 139 140 (define (check s) (lambda (s1) (if (null? s1) (err s) s1))) 132 141 133 142 (define (num-parser s) … … 139 148 (sign (opt (char #\-)) ) 140 149 (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)))))))))150 (reverse (car (longest (pat (check s) `((() ,(->char-list s))))))))) 142 151 143 152 … … 147 156 (num-parser "-3.45e-6")) 148 157 ) 158
Note: See TracChangeset
for help on using the changeset viewer.