Changeset 14885 in project


Ignore:
Timestamp:
06/05/09 04:44:43 (10 years ago)
Author:
Ivan Raikov
Message:

added cps-table in lexgen

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

Legend:

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

    r14871 r14885  
    4444    try pass pos opt char
    4545    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)
    5153
    5254;;
     
    7577(define (tok t p)
    7678  (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)
    8184                    (else #f)))))
    82     (lambda (a r streams)
     85    (lambda (cont streams)
    8386      (let ((streams1 (filter-map f streams)))
    84         (if (null? streams1) (r streams) (a streams1))))))
     87        (cont streams1)))))
    8588   
    8689
     
    8891
    8992(define (seq p1 p2)
    90   (lambda (a r streams)
    91     (p1 (lambda (streams1) (p2 a r streams1)) r streams)))
     93  (lambda (cont streams)
     94    (p1 (lambda (streams1) (p2 cont streams1)) streams)))
    9295
    9396
     
    9699
    97100(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))))
    101105
    102106
     
    104108
    105109(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)))))
    111117
    112118;; The rest of these are built from the previous four and are provided
     
    114120
    115121;; this parser always succeeds
    116 (define (pass a r s) (a s))
     122(define (pass cont s) (cont s))
    117123 
    118124;; Positive closure. Analogous to '+'
     
    189195(define (lex pat error s)
    190196  (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))))))
    192198    (and res (list (reverse (first res)) (second res)))))
    193199
     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
    194240)
  • release/4/lexgen/trunk/lexgen.setup

    r14871 r14885  
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (compile -O2 -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)
    88
    99(install-extension
     
    1717
    1818  ;; Assoc list with properties for your extension:
    19   '((version 2.2)
     19  '((version 2.3)
    2020    (documentation "lexgen.html")
    2121    ))
  • release/4/lexgen/trunk/tests/run.scm

    r14871 r14885  
    1313(define a-star-b-opt-pat (seq (star a-pat) (opt b-pat)))
    1414(define aabac-pat (lit "aabac"))
     15(define aa-pat (lit "aa"))
     16
     17(define aa-star-memo-pat (star (cps-table  aa-pat (try <))))
    1518 
    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"))))
    1923
    2024(define (err s)
     
    2428(test-group "lexgen test"
    2529            (test (sprintf "match [a] on ~S" "abc")
    26                    `(((#\a) (#\b #\c))) (a-pat identity err abc-stream))
     30                   `(((#\a) (#\b #\c))) (a-pat identity abc-stream))
    2731
    2832            (test (sprintf "match [b] on ~S" "abc")
    29                    `() (b-pat identity err abc-stream))
     33                   `() (b-pat identity abc-stream))
    3034
    3135            (test (sprintf "match ab on ~S" "abc")
    3236                   `(((#\b #\a ) ( #\c)))
    33                    (a-then-b-pat identity err abc-stream))
     37                   (a-then-b-pat identity abc-stream))
    3438
    3539            (test (sprintf "match a|b on ~S" "abc")
    3640                   `(((#\a) (#\b #\c)))
    37                    (a-or-b-pat identity err abc-stream))
     41                   (a-or-b-pat identity abc-stream))
    3842
    3943            (test (sprintf "match a|b on ~S" "bac")
    4044                   `(((#\b) (#\a #\c)))
    41                    (a-or-b-pat identity err bac-stream))
     45                   (a-or-b-pat identity bac-stream))
    4246
    4347            (test (sprintf "match a* on ~S" "abc")
    4448                   `((() (#\a #\b #\c)) ((#\a) (#\b #\c)))
    45                    (a-star-pat identity err abc-stream))
     49                   (a-star-pat identity abc-stream))
    4650
    4751            (test (sprintf "match a* on ~S" "aabac")
    4852                  `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
    49                   (a-star-pat identity err aabac-stream))
     53                  (a-star-pat identity aabac-stream))
    5054
    5155            (test (sprintf "match (a*|b) on ~S" "aabac")
    5256                   `((() (#\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))
     57                   (a-star-or-b-pat identity aabac-stream))
    5458
    5559            (test (sprintf "match (a|b)* on ~S" "abc")
    5660                   `((() (#\a #\b #\c))  ((#\a) (#\b #\c)) ((#\b #\a) (#\c)))
    57                    (a-or-b-star-pat identity err abc-stream))
     61                   (a-or-b-star-pat identity abc-stream))
    5862
    5963            (test (sprintf "match (a|b)* on ~S" "aabac")
    6064                   `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c))
    6165                     ((#\b #\a #\a) (#\a #\c)) ((#\a #\b #\a #\a) (#\c)))
    62                    (a-or-b-star-pat identity err aabac-stream))
     66                   (a-or-b-star-pat identity aabac-stream))
    6367
    6468            (test (sprintf "match ab? on ~S" "aabac")
    6569                   `(((#\a) (#\a #\b #\a #\c)) )
    66                    (a-b-opt-pat identity err aabac-stream))
     70                   (a-b-opt-pat identity aabac-stream))
    6771
    6872            (test (sprintf "match ab? on ~S" "abc")
    6973                   `(((#\b #\a) (#\c)) )
    70                    (a-b-opt-pat identity err abc-stream))
     74                   (a-b-opt-pat identity abc-stream))
    7175
    7276            (test (sprintf "match a*b? on ~S" "aabac")
    7377                   `(((#\b #\a #\a) (#\a #\c)) )
    74                    (a-star-b-opt-pat identity err aabac-stream))
     78                   (a-star-b-opt-pat identity aabac-stream))
    7579
    7680            (test (sprintf "match literal string ~S" "aabac")
    7781                   `(((#\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))
    7989
    8090            )
    81 
    8291;; A pattern to match floating point numbers.
    8392;; "-"?(([0-9]+(\\.[0-9]+)?)|(\\.[0-9]+))([eE][+-]?[0-9]+)?
     
    98107            (test (sprintf "match numpat on ~S" "hi there")
    99108                  #f (lex numpat err "hi there")))
    100 
    101109(define (->char-list s)
    102110  (if (string? s) (string->list s) s))
    103111
    104112(define (bind f p)
    105   (lambda (a r s)
    106     (let ((a1 (lambda (s1)
     113  (lambda (cont s)
     114    (let ((cont1 (lambda (s1)
    107115                (match (longest s1)
    108116                       ((eaten food)
    109117                        (let ((x (f eaten)))
    110                           (a `((,x ,food)))))
     118                          (cont `((,x ,food)))))
    111119                       (else #f)))))
    112       (p a1 r s))))
     120      (p cont1 s))))
    113121           
    114122(define ($ cs)
     
    130138                       (cons `(sign ,(car x1)) (cdr x1)))) x))
    131139
     140(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))
    132141
    133142(define (num-parser s)
     
    139148         (sign         (opt (char #\-)) )
    140149         (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)))))))))
    142151
    143152
     
    147156                   (num-parser "-3.45e-6"))
    148157            )
     158
Note: See TracChangeset for help on using the changeset viewer.