Changeset 25779 in project


Ignore:
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:
6 edited

Legend:

Unmodified
Added
Removed
  • release/4/abnf/trunk/abnf.meta

    r23287 r25779  
    1818 ; A list of eggs abnf depends on.
    1919
    20  (needs typeclass input-classes (lexgen 5.1) )
     20 (needs typeclass input-classes (lexgen 5.1) suffix-tree )
    2121
    2222;; (test-depends test)
  • release/4/abnf/trunk/abnf.scm

    r23972 r25779  
    44;;
    55;;
    6 ;;   Copyright 2009-2011 Ivan Raikov and the Okinawa Institute of Science
     6;;   Copyright 2009-2012 Ivan Raikov and the Okinawa Institute of Science
    77;;   and Technology.
    88;;
     
    4040   (import scheme chicken data-structures extras )
    4141
    42    (require-extension srfi-1 srfi-14 srfi-69 typeclass input-classes)
     42   (require-extension srfi-1 srfi-14 srfi-69 typeclass input-classes suffix-tree)
    4343
    4444   (require-library lexgen)
     
    5454  binary decimal hexadecimal ascii-char cr lf crlf ctl
    5555  dquote htab lwsp octet sp vchar wsp
     56  alternatives/prefix
    5657  :s :c )
    5758
     
    200201    (set (string->char-set s))))
    201202
     203;;
     204;; A variant of alternatives optimized for parsing grammars with a
     205;; large number of alternatives that are each prefixed by a constant
     206;; string, e.g. email headers:
     207;;
     208;;  From: <mailbox parser>
     209;;  To: <mailbox parser>
     210;;  Subject: <text parser>
     211;;  ...
     212;;
     213
     214(define=> (alternatives/prefix <CharLex>)
     215  (lambda (prefixes #!key
     216                    (default (lambda (sk fk strm) (fk strm)))
     217                    (char-bind #f)
     218                    (join cons))
     219
     220    (let ((bind-proc (lambda (path eol)
     221                       (lex:bind (lambda (x)
     222                                   (join (char-bind path) (reverse x))) eol)))
     223
     224          (tr (fold (lambda (x t) (suffix-tree-insert (car x) (cdr x) t))
     225                    (make-suffix-tree char<=? string->list)
     226                    prefixes)))
     227
     228      (let recur ((branches (suffix-tree-branches tr))
     229                  (p default)
     230                  (path '()) )
     231
     232        (if (null? branches) p
     233            (let ((branch (car branches)))
     234              (let ((eol (suffix-tree-branch-eol branch))
     235                    (label (suffix-tree-branch-label branch)))
     236                (recur (cdr branches)
     237                       (lex:bar (lex:seq (drop-consumed (char label))
     238                                         (or (and eol (if char-bind (bind-proc (cons label path) eol) eol))
     239                                             (recur
     240                                              (suffix-tree-branch-children branch)
     241                                              (lambda (sk fk strm) (fk strm))
     242                                              (cons label path))
     243                                             ))
     244                                p)
     245                       path
     246                       ))
     247              ))
     248        ))
     249    ))
     250
     251;;;; Type class constructor
    202252
    203253(define (CharLex->CoreABNF L)
     
    223273         (vchar       (vchar L))
    224274         (set-from-string  (set-from-string L))
     275         (alternatives/prefix (alternatives/prefix L))
    225276         (:c          char)
    226277         (:s          lit)
     
    232283                   binary decimal hexadecimal ascii-char cr lf crlf ctl
    233284                   dquote htab lwsp octet sp vchar wsp
     285                   alternatives/prefix
    234286                   :s :c )
    235287  ))
  • release/4/abnf/trunk/abnf.setup

    r24008 r25779  
    33(define (dynld-name fn)         
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    5 
    6 (required-extension-version 'lexgen 5.1)
    75
    86(compile -O -d2 -S -s abnf.scm -j abnf)
     
    2725
    2826  ;; Assoc list with properties for your extension:
    29   '((version 5.1)
     27  '((version 6.0)
    3028    ))
  • release/4/internet-message/trunk/internet-message.meta

    r23287 r25779  
    1818 ; A list of eggs internet-message depends on.
    1919
    20  (needs (abnf 5.0) )
     20 (needs (abnf 6.0) )
    2121
    2222 (test-depends test)
  • release/4/internet-message/trunk/internet-message.scm

    r24963 r25779  
    44;;  Based on the Haskell Rfc2822 module by Peter Simons.
    55;;
    6 ;;  Copyright 2009-2011 Ivan Raikov and the Okinawa Institute of
     6;;  Copyright 2009-2012 Ivan Raikov and the Okinawa Institute of
    77;;  Science and Technology.
    88;;
     
    7070  (lambda (s p) 
    7171    (let ((ss (->string s)))
    72       (lambda (#!key (crlf crlf) (alist #f))
    73         (if alist
    74             (let ((value (abnf:bind (consumed-objects-lift-any)
    75                                     (abnf:concatenation
    76                                      p
    77                                      (abnf:drop-consumed crlf)))))
    78               (lambda (kv)
    79                 (and (string=? (string-downcase ss) (string-downcase (car kv)))
    80                      (list ss (value (cdr kv))))))
     72      (lambda (#!key (crlf crlf) (prefix #t))
     73        (if prefix
     74            `(,ss . ,(abnf:concatenation
     75                      (abnf:drop-consumed (char #\:))
     76                      p
     77                      (abnf:drop-consumed crlf)))
    8178            (abnf:bind (consumed-objects-lift-any)
    8279                       (abnf:concatenation
     
    8582                           p
    8683                           (abnf:drop-consumed crlf)))
    87             )))))
     84            )))
     85    ))
    8886
    8987
     
    823821(define=> (optional-field  <CoreABNF>)
    824822  (lambda (field-name unstructured)
    825     (lambda (#!key (crlf crlf) (alist #f))
     823    (lambda (#!key (crlf crlf) )
    826824      (abnf:bind (consumed-objects-lift-any)
    827825                 (abnf:concatenation
    828                   (if alist
    829                       abnf:pass
    830                       (abnf:concatenation
    831                        field-name
    832                        (abnf:drop-consumed (char #\:))))
     826                  (abnf:concatenation
     827                   field-name
     828                   (abnf:drop-consumed (char #\:)))
    833829                  unstructured
    834830                  (abnf:drop-consumed crlf))))))
     
    852848      (abnf:repetition
    853849       (abnf:alternatives
    854         (from           crlf: crlf)
    855         (sender         crlf: crlf)
    856         (return-path    crlf: crlf)
    857         (reply-to       crlf: crlf)
    858         (to             crlf: crlf)
    859         (cc             crlf: crlf)
    860         (bcc            crlf: crlf)
    861         (message-id     crlf: crlf)
    862         (in-reply-to    crlf: crlf)
    863         (references     crlf: crlf)
    864         (subject        crlf: crlf)
    865         (comments       crlf: crlf)
    866         (keywords       crlf: crlf)
    867         (orig-date      crlf: crlf)
    868         (resent-date    crlf: crlf)
    869         (resent-from    crlf: crlf)
    870         (resent-sender  crlf: crlf)
    871         (resent-to      crlf: crlf)
    872         (resent-cc      crlf: crlf)
    873         (resent-bcc     crlf: crlf)
    874         (resent-msg-id    crlf: crlf)
    875         (resent-reply-to  crlf: crlf)
    876         (received         crlf: crlf)
    877         (optional-field   crlf: crlf)))
     850        (alternatives/prefix
     851         (list
     852          (from           crlf: crlf)
     853          (sender         crlf: crlf)
     854          (return-path    crlf: crlf)
     855          (reply-to       crlf: crlf)
     856          (to             crlf: crlf)
     857          (cc             crlf: crlf)
     858          (bcc            crlf: crlf)
     859          (message-id     crlf: crlf)
     860          (in-reply-to    crlf: crlf)
     861          (references     crlf: crlf)
     862          (subject        crlf: crlf)
     863          (comments       crlf: crlf)
     864          (keywords       crlf: crlf)
     865          (orig-date      crlf: crlf)
     866          (resent-date    crlf: crlf)
     867          (resent-from    crlf: crlf)
     868          (resent-sender  crlf: crlf)
     869          (resent-to      crlf: crlf)
     870          (resent-cc      crlf: crlf)
     871          (resent-bcc     crlf: crlf)
     872          (resent-msg-id    crlf: crlf)
     873          (resent-reply-to  crlf: crlf)
     874          (received         crlf: crlf))
     875         char-bind: consumed-chars->tsymbol
     876         join: (compose list append))
     877        (optional-field   crlf: crlf)
     878        ))
    878879  )))
    879880
  • release/4/internet-message/trunk/internet-message.setup

    r24963 r25779  
    33(define (dynld-name fn)         
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    5 
    6 (required-extension-version 'abnf 5.0)
    75
    86(compile -O3 -d0 -s internet-message.scm -j internet-message)
     
    1917
    2018  ;; Assoc list with properties for your extension:
    21   '((version 5.3)
     19  '((version 5.4)
    2220    ))
    2321
Note: See TracChangeset for help on using the changeset viewer.