Changeset 14865 in project


Ignore:
Timestamp:
06/03/09 07:33:51 (10 years ago)
Author:
Ivan Raikov
Message:

cps variant of lexgen

Location:
release/4/lexgen/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/lexgen/trunk/lexgen.scm

    r14820 r14865  
    4242
    4343  ( tok seq star bar
    44     try pos opt char
     44    try pass pos opt char
    4545    set range lit
    4646    longest lex )
     
    7575(define (tok t p)
    7676  (let ((f (lambda (s)
    77              (match s ((s (h . r))
     77             (match s ((c (h . r))
    7878                       (let ((ans (p t h)))
    79                          (and ans (list (cons ans s) r))))
     79                         (and ans (list (cons ans c) r))))
     80                    ((c ())  s) 
    8081                    (else #f)))))
    81     (lambda (streams)
    82       (filter-map f streams))))
     82    (lambda (a r streams)
     83      (let ((streams1 (filter-map f streams)))
     84        (if (null? streams1) (r streams) (a streams1))))))
    8385   
    8486
    8587;; This matches a sequence of patterns.
    8688
    87 (define (seq pats)
    88   (lambda (streams)
    89     (fold (lambda (f s) (f s)) streams pats)))
     89(define (seq p1 p2)
     90  (lambda (a r streams)
     91    (p1 (lambda (streams1) (p2 a r streams1)) r streams)))
    9092
    91 ;; This matches any of a list of patterns. It's analogous to a series
    92 ;; of patterns separated by the '|' in traditional regular
    93 ;; expressions.
    9493
    95 (define (bar pats)
    96   (lambda (streams)
    97     (concatenate (map (lambda (f) (f streams)) pats))))
     94;; This matches either one of two patterns. It's analogous to patterns
     95;; separated by the '|' in regular expressions.
     96
     97(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
    98102
    99103;; Kleene closure. Analogous to '*'
    100104
    101 (define (star pat)
    102   (define (f streams)
    103     (let ((res (pat streams)))
    104       (if (null? res) (list)
    105           (cons res (f res)))))
    106   (lambda (streams)
    107     (concatenate (cons streams (f streams)))))
     105(define (star p)
     106  (lambda (a r streams)
     107    (let* ((r1 (lambda (streams1) (a (concatenate (list streams streams1)))))
     108           (a2 (lambda (streams1) (p (lambda (streams2) (a (concatenate (list streams streams1 streams2)))) r1 streams1)))
     109           (a1 (lambda (streams1) (p a2 r1 streams1))))
     110      (p a1 a streams))))
    108111
    109112
     
    111114;; for convenience.
    112115
     116;; this parser always succeeds
     117(define (pass a r s)
     118  (a s))
     119 
    113120;; Positive closure. Analogous to '+'
    114121
    115122(define (pos pat)
    116   (seq (list pat (star pat))))
     123  (seq pat (star pat)))
    117124
    118125;; Optional pattern. Analogous to '?'
    119126
    120127(define (opt pat)
    121   (bar (list pat identity)))
     128  (bar pat pass))
    122129
    123130;; Converts a binary predicate procedure to a binary procedure that
     
    175182  (if (string? s) (string->list s) s))
    176183
    177 (define (lex pat s)
     184(define (lex pat error s)
    178185  (let* ((stream (->char-list s))
    179          (res    (longest (pat `((() ,stream))))))
     186         (res    (longest (pat identity error `((() ,stream))))))
    180187    (and res (list (reverse (first res)) (second res)))))
    181188
  • release/4/lexgen/trunk/lexgen.setup

    r14810 r14865  
    1717
    1818  ;; Assoc list with properties for your extension:
    19   '((version 1.5)
     19  '((version 2.0)
    2020    (documentation "lexgen.html")
    2121    ))
  • release/4/lexgen/trunk/tests/run.scm

    r14699 r14865  
    55(define a-pat (tok #\a (try char=?)))
    66(define b-pat (tok #\b (try char=?)))
    7 (define a-then-b-pat (seq (list a-pat b-pat)))
    8 (define a-or-b-pat (seq (list a-pat b-pat)))
     7(define a-then-b-pat (seq a-pat b-pat))
     8(define a-or-b-pat (bar a-pat b-pat))
    99(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)))
    1014 
    1115(define abc-stream (list `(() ,(string->list "abc"))))
     16(define bac-stream (list `(() ,(string->list "bac"))))
     17(define aabac-stream (list `(() ,(string->list "aabac"))))
    1218
    13 (print (a-pat abc-stream))
     19(define (err s)
     20  (print "lexical error on stream: " s)
     21  (list))
    1422
    1523(test-group "lexgen test"
    1624            (test (sprintf "match [a] on ~S" "abc")
    17                    `(((#\a) (#\b #\c))) (a-pat abc-stream))
     25                   `(((#\a) (#\b #\c))) (a-pat identity err abc-stream))
     26
    1827            (test (sprintf "match [b] on ~S" "abc")
    19                    `() (b-pat abc-stream))
     28                   `() (b-pat identity err abc-stream))
     29
    2030            (test (sprintf "match ab on ~S" "abc")
    21                    `(((#\b #\a ) ( #\c))) (a-then-b-pat abc-stream))
     31                   `(((#\b #\a ) ( #\c)))
     32                   (a-then-b-pat identity err abc-stream))
     33
    2234            (test (sprintf "match a|b on ~S" "abc")
    23                    `(((#\b #\a ) ( #\c))) (a-or-b-pat abc-stream))
     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
    2442            (test (sprintf "match a* on ~S" "abc")
    25                    `((() (#\a #\b #\c)) ((#\a) (#\b #\c))) (a-star-pat abc-stream))
     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
    2674            )
    27 
    2875
    2976;; A pattern to match floating point numbers.
     
    3380  (let* ((digit        (range #\0 #\9))
    3481         (digits       (pos digit))
    35          (fraction     (seq `(,(char #\.) ,digits)))
    36          (significand  (bar `(,(seq `(,digits ,(opt fraction))) ,fraction)))
    37          (exp          (seq `(,(set "eE") ,(opt (set "+-")) ,digits)))
    38          (sign         (opt (char #\-)) ))     
    39     (seq `(,sign ,(seq `(,significand ,(opt exp)))))))
     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
    4088
    4189(test-group "lexgen numpat test"
    4290            (test (sprintf "match numpat on ~S" "-3.45e-6")
    43                    `((#\- #\3 #\. #\4 #\5 #\e #\- #\6) ()) (lex numpat "-3.45e-6"))
     91                   `((#\- #\3 #\. #\4 #\5 #\e #\- #\6) ()) (lex numpat err "-3.45e-6"))
    4492            (test (sprintf "match numpat on ~S" "hi there")
    45                   #f (lex numpat "hi there")))
    46 
     93                  #f (lex numpat err "hi there")))
    4794
    4895(define (->char-list s)
     
    5097
    5198(define (bind f p)
    52   (lambda (s)
    53     (let ((s1 (p s)))
    54       (match (longest (p s))
    55              ((eaten food)
    56               (let ((x (f eaten)))
    57                 (and x `((,x ,food)))))
    58              (else #f)))))
     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))))
    59107           
    60108(define ($ cs)
     
    80128  (let* ((digit        (range #\0 #\9))
    81129         (digits       (star digit))
    82          (fraction     (seq `(,(char #\.) ,digits)))
    83          (significand  (bar `(,(seq `(,digits ,(opt fraction))) ,fraction)))
    84          (exp          (seq `(,(set "eE") ,(opt (set "+-")) ,digits)))
     130         (fraction     (seq (char #\.) digits))
     131         (significand  (bar (seq digits (opt fraction)) fraction))
     132         (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
    85133         (sign         (opt (char #\-)) )
    86          (pat     (seq `(,(bind make-sign sign) ,(bind make-significand significand) ,(bind make-exp (opt exp))))))
    87     (reverse (car (longest (pat `((() ,(->char-list s)))))))))
     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)))))))))
    88136
    89137
Note: See TracChangeset for help on using the changeset viewer.