Changeset 14885 in project

Timestamp:

06/05/09 04:44:43 (11 years ago)

Author:

Ivan Raikov

Message:

added cps-table in lexgen

Location:

release/4/lexgen/trunk

Files:

• lexgen.scm (modified) (7 diffs)
• lexgen.setup (modified) (2 diffs)
• tests/run.scm (modified) (6 diffs)

release/4/lexgen/trunk/lexgen.scm

@@ -44 +44 @@
     try pass pos opt char 
     set range lst lit 
-    longest lex )
-
-
-   (import scheme chicken data-structures srfi-14)
-   (require-extension srfi-1 matchable)
+    cps-table longest lex )
+
+
+   (import scheme chicken data-structures
+           (only srfi-1 first second filter-map fold concatenate) 
+           srfi-14 srfi-69)
+   (require-extension matchable)
 
 ;;
@@ -75 +77 @@
 (define (tok t p)
   (let ((f (lambda (s) 
-             (match s ((c (h . r)) 
-                       (let ((ans (p t h)))
-                         (and ans (list (cons ans c) r))))
-                    ((c ())  s)  
+             (match s
+                    ((c (h . r)) 
+                     (let ((ans (p t h)))
+                       (and ans (list (cons ans c) r))))
+                    ((c ())  s)
                     (else #f)))))
-    (lambda (a r streams)
+    (lambda (cont streams)
       (let ((streams1 (filter-map f streams)))
-        (if (null? streams1) (r streams) (a streams1))))))
+        (cont streams1)))))
     
 
@@ -88 +91 @@
 
 (define (seq p1 p2)
-  (lambda (a r streams)
-    (p1 (lambda (streams1) (p2 a r streams1)) r streams)))
+  (lambda (cont streams)
+    (p1 (lambda (streams1) (p2 cont streams1)) streams)))
 
 
@@ -96 +99 @@
 
 (define (bar p1 p2)
-  (lambda (a r streams)
-    (let ((r1 (lambda (streams1) (p2 a (lambda (streams2) (r streams1)) streams)) ))
-      (p1 a r1 streams))))
+  (lambda (cont streams)
+    (let ((cont1 (lambda (streams1) 
+                   (if (null? streams1) (p2 cont streams) (cont streams1)))))
+      (p1 cont1 streams))))
 
 
@@ -104 +108 @@
 
 (define (star p)
-  (lambda (a r streams)
-    (let ((a1 (lambda (streams1) (a (concatenate (list streams streams1))))))
-      (p (lambda (streams1) (if (equal? streams streams1) (a streams1)
-                                ((star p) a1 a1 streams1)))
-         a streams))))
+  (lambda (cont streams)
+    (if (null? streams) (cont streams)
+        (let ((cont1 (lambda (streams1) (cont (concatenate (list streams streams1))))))
+          (p (lambda (streams1) 
+               (cond ((equal? streams streams1) (cont streams))
+                     (else  ((star p) cont1 streams1))))
+             streams)))))
 
 ;; The rest of these are built from the previous four and are provided
@@ -114 +120 @@
 
 ;; this parser always succeeds
-(define (pass a r s) (a s))
+(define (pass cont s) (cont s))
   
 ;; Positive closure. Analogous to '+' 
@@ -189 +195 @@
 (define (lex pat error s)
   (let* ((stream (->char-list s))
-         (res    (longest (pat identity error `((() ,stream))))))
+         (res    (longest (pat (lambda (s1) (if (null? s1) (error s) s1)) `((() ,stream))))))
     (and res (list (reverse (first res)) (second res)))))
 
+
+(define make-table      make-hash-table)
+(define table-ref       hash-table-ref/default)
+(define table-put!      hash-table-set!)
+(define table-for-each  hash-table-for-each)
+
+
+;; tabled execution wrapper
+;; from _Tabled Execution in Scheme_, by Willcock, et al.
+
+(define (cps-table f combine)
+  (let ((memo    (make-table equal?))
+        (k-list  (make-table equal?)))
+    (lambda (k arg)
+      (table-put! k-list arg (cons k (table-ref k-list arg (list))))
+      (if (not (table-ref memo arg  #f))
+          (let ((memo-table (make-table)))
+            (print "miss: arg = " arg)
+            (table-put! memo arg memo-table)
+            (f (lambda (result)
+                 (print "miss: result = " result)
+                 (if (null? result) (k result)
+                     (let* ((len     (length result))
+                            (old-len (table-ref memo-table result #f))
+                            (new-len (combine (or old-len 0) len)))
+                       (print "len = " len)
+                       (print "old-len = " old-len)
+                       (print "new-len = " new-len)
+                       (if (not (equal? old-len new-len))
+                           (begin
+                             (table-put! memo-table result new-len)
+                             (for-each (lambda (saved-k) (saved-k result))
+                                       (table-ref k-list arg (list))))))))
+               
+               arg))
+          (let ((memo-table (table-ref memo arg #f) ))
+            (print "hit: arg = " arg)
+            (table-for-each memo-table (lambda (result len) (k result)))
+            )))))
+
 )

release/4/lexgen/trunk/lexgen.setup

@@ -4 +4 @@
   (make-pathname #f fn ##sys#load-dynamic-extension))   
 
-(compile -O2 -d0 -s lexgen.scm -j lexgen)
-(compile -O2 -d0 -s lexgen.import.scm)
+(compile -O -d2 -s lexgen.scm -j lexgen)
+(compile -s lexgen.import.scm)
 
 (install-extension
@@ -17 +17 @@
 
   ;; Assoc list with properties for your extension:
-  '((version 2.2)
+  '((version 2.3)
     (documentation "lexgen.html")
     ))

release/4/lexgen/trunk/tests/run.scm

@@ -13 +13 @@
 (define a-star-b-opt-pat (seq (star a-pat) (opt b-pat)))
 (define aabac-pat (lit "aabac"))
+(define aa-pat (lit "aa"))
+
+(define aa-star-memo-pat (star (cps-table  aa-pat (try <))))
   
-(define abc-stream (list `(() ,(string->list "abc"))))
-(define bac-stream (list `(() ,(string->list "bac"))))
-(define aabac-stream (list `(() ,(string->list "aabac"))))
+(define abc-stream      (list `(() ,(string->list "abc"))))
+(define bac-stream      (list `(() ,(string->list "bac"))))
+(define aabac-stream    (list `(() ,(string->list "aabac"))))
+(define aaaabac-stream  (list `(() ,(string->list "aaaabac"))))
 
 (define (err s)
@@ -24 +28 @@
 (test-group "lexgen test"
             (test (sprintf "match [a] on ~S" "abc") 
-                   `(((#\a) (#\b #\c))) (a-pat identity err abc-stream))
+                   `(((#\a) (#\b #\c))) (a-pat identity abc-stream))
 
             (test (sprintf "match [b] on ~S" "abc") 
-                   `() (b-pat identity err abc-stream))
+                   `() (b-pat identity abc-stream))
 
             (test (sprintf "match ab on ~S" "abc") 
                    `(((#\b #\a ) ( #\c))) 
-                   (a-then-b-pat identity err abc-stream))
+                   (a-then-b-pat identity abc-stream))
 
             (test (sprintf "match a|b on ~S" "abc") 
                    `(((#\a) (#\b #\c))) 
-                   (a-or-b-pat identity err abc-stream))
+                   (a-or-b-pat identity abc-stream))
 
             (test (sprintf "match a|b on ~S" "bac") 
                    `(((#\b) (#\a #\c))) 
-                   (a-or-b-pat identity err bac-stream))
+                   (a-or-b-pat identity bac-stream))
 
             (test (sprintf "match a* on ~S" "abc") 
                    `((() (#\a #\b #\c)) ((#\a) (#\b #\c))) 
-                   (a-star-pat identity err abc-stream))
+                   (a-star-pat identity abc-stream))
 
             (test (sprintf "match a* on ~S" "aabac") 
                   `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
-                  (a-star-pat identity err aabac-stream))
+                  (a-star-pat identity  aabac-stream))
 
             (test (sprintf "match (a*|b) on ~S" "aabac") 
                    `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)))
-                   (a-star-or-b-pat identity err aabac-stream))
+                   (a-star-or-b-pat identity  aabac-stream))
 
             (test (sprintf "match (a|b)* on ~S" "abc") 
                    `((() (#\a #\b #\c))  ((#\a) (#\b #\c)) ((#\b #\a) (#\c)))
-                   (a-or-b-star-pat identity err abc-stream))
+                   (a-or-b-star-pat identity  abc-stream))
 
             (test (sprintf "match (a|b)* on ~S" "aabac") 
                    `((() (#\a #\a #\b #\a #\c)) ((#\a ) (#\a #\b #\a #\c)) ((#\a #\a) (#\b #\a #\c)) 
                      ((#\b #\a #\a) (#\a #\c)) ((#\a #\b #\a #\a) (#\c)))
-                   (a-or-b-star-pat identity err aabac-stream))
+                   (a-or-b-star-pat identity  aabac-stream))
 
             (test (sprintf "match ab? on ~S" "aabac") 
                    `(((#\a) (#\a #\b #\a #\c)) )
-                   (a-b-opt-pat identity err aabac-stream))
+                   (a-b-opt-pat identity  aabac-stream))
 
             (test (sprintf "match ab? on ~S" "abc") 
                    `(((#\b #\a) (#\c)) )
-                   (a-b-opt-pat identity err abc-stream))
+                   (a-b-opt-pat identity  abc-stream))
 
             (test (sprintf "match a*b? on ~S" "aabac") 
                    `(((#\b #\a #\a) (#\a #\c)) )
-                   (a-star-b-opt-pat identity err aabac-stream))
+                   (a-star-b-opt-pat identity aabac-stream))
 
             (test (sprintf "match literal string ~S" "aabac") 
                    `(((#\c #\a #\b #\a #\a) ()) )
-                   (aabac-pat identity err aabac-stream))
+                   (aabac-pat identity aabac-stream))
+
+            (test (sprintf "match memoized (aa)* on ~S" "aaaabac") 
+                  `((() (#\a #\a #\a #\a #\b #\a #\c)) ((#\a #\a ) (#\a #\a #\b #\a #\c)) ((#\a #\a #\a #\a) (#\b #\a #\c)))
+                   (let ((res #f))
+                     (aa-star-memo-pat (lambda (x) (set! res x)) aaaabac-stream)
+                     res))
 
             )
-
 ;; A pattern to match floating point numbers. 
 ;; "-"?(([0-9]+(\\.[0-9]+)?)|(\\.[0-9]+))([eE][+-]?[0-9]+)? 
@@ -98 +107 @@
             (test (sprintf "match numpat on ~S" "hi there")
                   #f (lex numpat err "hi there")))
-
 (define (->char-list s)
   (if (string? s) (string->list s) s))
 
 (define (bind f p)
-  (lambda (a r s)
-    (let ((a1 (lambda (s1) 
+  (lambda (cont s)
+    (let ((cont1 (lambda (s1) 
                 (match (longest s1)
                        ((eaten food) 
                         (let ((x (f eaten)))
-                          (a `((,x ,food)))))
+                          (cont `((,x ,food)))))
                        (else #f)))))
-      (p a1 r s))))
+      (p cont1 s))))
            
 (define ($ cs) 
@@ -130 +138 @@
                        (cons `(sign ,(car x1)) (cdr x1)))) x))
 
+(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))
 
 (define (num-parser s)
@@ -139 +148 @@
          (sign         (opt (char #\-)) )
          (pat          (seq (bind make-sign sign) (seq (bind make-significand significand) (bind make-exp (opt exp))))))
-    (reverse (car (longest (pat identity err `((() ,(->char-list s)))))))))
+    (reverse (car (longest (pat (check s) `((() ,(->char-list s)))))))))
 
 
@@ -147 +156 @@
                    (num-parser "-3.45e-6"))
             )
+