Changeset 25779 in project

Timestamp:

01/07/12 13:07:40 (9 years ago)

Author:

Ivan Raikov

Message:

abnd and internet-message: introduced alternatives/prefix combinator and some slight optimizations based on it

Location:

release/4

Files:

• abnf/trunk/abnf.meta (modified) (1 diff)
• abnf/trunk/abnf.scm (modified) (6 diffs)
• abnf/trunk/abnf.setup (modified) (2 diffs)
• internet-message/trunk/internet-message.meta (modified) (1 diff)
• internet-message/trunk/internet-message.scm (modified) (5 diffs)
• internet-message/trunk/internet-message.setup (modified) (2 diffs)

release/4/abnf/trunk/abnf.meta

@@ -18 +18 @@
  ; A list of eggs abnf depends on.
 
- (needs typeclass input-classes (lexgen 5.1) )
+ (needs typeclass input-classes (lexgen 5.1) suffix-tree )
 
 ;; (test-depends test)

release/4/abnf/trunk/abnf.scm

@@ -4 +4 @@
 ;;
 ;;
-;;   Copyright 2009-2011 Ivan Raikov and the Okinawa Institute of Science
+;;   Copyright 2009-2012 Ivan Raikov and the Okinawa Institute of Science
 ;;   and Technology.
 ;;
@@ -40 +40 @@
    (import scheme chicken data-structures extras )
 
-   (require-extension srfi-1 srfi-14 srfi-69 typeclass input-classes)
+   (require-extension srfi-1 srfi-14 srfi-69 typeclass input-classes suffix-tree)
 
    (require-library lexgen)
@@ -54 +54 @@
   binary decimal hexadecimal ascii-char cr lf crlf ctl 
   dquote htab lwsp octet sp vchar wsp 
+  alternatives/prefix
   :s :c )
 
@@ -200 +201 @@
     (set (string->char-set s))))
 
+;;
+;; A variant of alternatives optimized for parsing grammars with a
+;; large number of alternatives that are each prefixed by a constant
+;; string, e.g. email headers:
+;;
+;;  From: <mailbox parser>
+;;  To: <mailbox parser>
+;;  Subject: <text parser>
+;;  ...
+;;
+
+(define=> (alternatives/prefix <CharLex>)
+  (lambda (prefixes #!key 
+                    (default (lambda (sk fk strm) (fk strm))) 
+                    (char-bind #f)
+                    (join cons))
+
+    (let ((bind-proc (lambda (path eol) 
+                       (lex:bind (lambda (x) 
+                                   (join (char-bind path) (reverse x))) eol)))
+
+          (tr (fold (lambda (x t) (suffix-tree-insert (car x) (cdr x) t))
+                    (make-suffix-tree char<=? string->list)
+                    prefixes)))
+
+      (let recur ((branches (suffix-tree-branches tr)) 
+                  (p default)
+                  (path '()) )
+
+        (if (null? branches) p
+            (let ((branch (car branches)))
+              (let ((eol (suffix-tree-branch-eol branch))
+                    (label (suffix-tree-branch-label branch)))
+                (recur (cdr branches)
+                       (lex:bar (lex:seq (drop-consumed (char label))
+                                         (or (and eol (if char-bind (bind-proc (cons label path) eol) eol))
+                                             (recur
+                                              (suffix-tree-branch-children branch)
+                                              (lambda (sk fk strm) (fk strm))
+                                              (cons label path))
+                                             ))
+                                p)
+                       path
+                       ))
+              ))
+        ))
+    ))
+
+;;;; Type class constructor
 
 (define (CharLex->CoreABNF L)
@@ -223 +273 @@
          (vchar       (vchar L))
          (set-from-string  (set-from-string L))
+         (alternatives/prefix (alternatives/prefix L))
          (:c          char)
          (:s          lit)
@@ -232 +283 @@
                    binary decimal hexadecimal ascii-char cr lf crlf ctl 
                    dquote htab lwsp octet sp vchar wsp 
+                   alternatives/prefix
                    :s :c )
   ))

release/4/abnf/trunk/abnf.setup

@@ -3 +3 @@
 (define (dynld-name fn)         
   (make-pathname #f fn ##sys#load-dynamic-extension))   
-
-(required-extension-version 'lexgen 5.1)
 
 (compile -O -d2 -S -s abnf.scm -j abnf)
@@ -27 +25 @@
 
   ;; Assoc list with properties for your extension:
-  '((version 5.1)
+  '((version 6.0)
     ))

release/4/internet-message/trunk/internet-message.meta

@@ -18 +18 @@
  ; A list of eggs internet-message depends on.
 
- (needs (abnf 5.0) )
+ (needs (abnf 6.0) )
 
  (test-depends test)

release/4/internet-message/trunk/internet-message.scm

@@ -4 +4 @@
 ;;  Based on the Haskell Rfc2822 module by Peter Simons.
 ;;
-;;  Copyright 2009-2011 Ivan Raikov and the Okinawa Institute of
+;;  Copyright 2009-2012 Ivan Raikov and the Okinawa Institute of
 ;;  Science and Technology.
 ;;
@@ -70 +70 @@
   (lambda (s p)  
     (let ((ss (->string s)))
-      (lambda (#!key (crlf crlf) (alist #f))
-        (if alist
-            (let ((value (abnf:bind (consumed-objects-lift-any)
-                                    (abnf:concatenation
-                                     p
-                                     (abnf:drop-consumed crlf)))))
-              (lambda (kv)
-                (and (string=? (string-downcase ss) (string-downcase (car kv)))
-                     (list ss (value (cdr kv))))))
+      (lambda (#!key (crlf crlf) (prefix #t))
+        (if prefix
+            `(,ss . ,(abnf:concatenation
+                      (abnf:drop-consumed (char #\:))
+                      p
+                      (abnf:drop-consumed crlf)))
             (abnf:bind (consumed-objects-lift-any)
                        (abnf:concatenation
@@ -85 +82 @@
                            p
                            (abnf:drop-consumed crlf)))
-            )))))
+            )))
+    ))
 
 
@@ -823 +821 @@
 (define=> (optional-field  <CoreABNF>)
   (lambda (field-name unstructured)
-    (lambda (#!key (crlf crlf) (alist #f))
+    (lambda (#!key (crlf crlf) )
       (abnf:bind (consumed-objects-lift-any)
                  (abnf:concatenation
-                  (if alist
-                      abnf:pass
-                      (abnf:concatenation
-                       field-name
-                       (abnf:drop-consumed (char #\:))))
+                  (abnf:concatenation
+                   field-name
+                   (abnf:drop-consumed (char #\:)))
                   unstructured
                   (abnf:drop-consumed crlf))))))
@@ -852 +848 @@
       (abnf:repetition
        (abnf:alternatives
-        (from           crlf: crlf)
-        (sender         crlf: crlf)
-        (return-path    crlf: crlf)
-        (reply-to       crlf: crlf)
-        (to             crlf: crlf)
-        (cc             crlf: crlf)
-        (bcc            crlf: crlf)
-        (message-id     crlf: crlf)
-        (in-reply-to    crlf: crlf)
-        (references     crlf: crlf)
-        (subject        crlf: crlf)
-        (comments       crlf: crlf)
-        (keywords       crlf: crlf)
-        (orig-date      crlf: crlf)
-        (resent-date    crlf: crlf)
-        (resent-from    crlf: crlf)
-        (resent-sender  crlf: crlf)
-        (resent-to      crlf: crlf)
-        (resent-cc      crlf: crlf)
-        (resent-bcc     crlf: crlf)
-        (resent-msg-id    crlf: crlf)
-        (resent-reply-to  crlf: crlf)
-        (received         crlf: crlf)
-        (optional-field   crlf: crlf)))
+        (alternatives/prefix
+         (list
+          (from           crlf: crlf)
+          (sender         crlf: crlf)
+          (return-path    crlf: crlf)
+          (reply-to       crlf: crlf)
+          (to             crlf: crlf)
+          (cc             crlf: crlf)
+          (bcc            crlf: crlf)
+          (message-id     crlf: crlf)
+          (in-reply-to    crlf: crlf)
+          (references     crlf: crlf)
+          (subject        crlf: crlf)
+          (comments       crlf: crlf)
+          (keywords       crlf: crlf)
+          (orig-date      crlf: crlf)
+          (resent-date    crlf: crlf)
+          (resent-from    crlf: crlf)
+          (resent-sender  crlf: crlf)
+          (resent-to      crlf: crlf)
+          (resent-cc      crlf: crlf)
+          (resent-bcc     crlf: crlf)
+          (resent-msg-id    crlf: crlf)
+          (resent-reply-to  crlf: crlf)
+          (received         crlf: crlf))
+         char-bind: consumed-chars->tsymbol
+         join: (compose list append))
+        (optional-field   crlf: crlf)
+        ))
   )))
 

release/4/internet-message/trunk/internet-message.setup

@@ -3 +3 @@
 (define (dynld-name fn)         
   (make-pathname #f fn ##sys#load-dynamic-extension))   
-
-(required-extension-version 'abnf 5.0)
 
 (compile -O3 -d0 -s internet-message.scm -j internet-message)
@@ -19 +17 @@
 
   ;; Assoc list with properties for your extension:
-  '((version 5.3)
+  '((version 5.4)
     ))