Changeset 14876 in project


Ignore:
Timestamp:
06/03/09 13:37:03 (10 years ago)
Author:
Ivan Raikov
Message:

abnf adapted to cps lexgen interface

Location:
release/4/abnf
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/abnf/abnf.scm

    r14842 r14876  
    3939(module abnf
    4040
    41    (alpha char
    42           binary decimal hexadecimal ascii-char lit cr lf crlf ctl
    43           dquote htab lwsp octet sp vchar wsp
    44           quoted-pair quoted-string
    45           concatenation alternatives range
    46           repetition repetition1 repetition-n
    47           optional-sequence
    48           set set-from-string
    49           bind drop-consumed collect-chars
    50           )
     41        (
     42         (concatenation lex:seq) (alternatives lex:bar)
     43         repetition repetition1 repetition-n
     44         optional-sequence range set set-from-string
     45
     46         char lit alpha
     47         binary decimal hexadecimal ascii-char cr lf crlf ctl
     48         dquote htab lwsp octet sp vchar wsp
     49         quoted-pair quoted-string
     50
     51         bind drop-consumed collect-chars
     52         )
    5153
    5254   (import scheme chicken data-structures )
     
    6264(define char lex:char)
    6365
    64 ;; Matches a literal string (case-insensitive)
    65 (define (lit s)
    66   (let ((f (lambda (t) (lex:tok t (lex:try char-ci=?)))))
    67     (lex:seq (map f (if (string? s) (string->list s) s)))))
    68 
    69 
    7066;; Concatenation (RFC 4234, Section 3.1)
    71 (define concatenation   lex:seq)
    72 
     67(define-syntax concatenation
     68  (syntax-rules ()
     69    ((_)     lex:pass)
     70    ((_ a)    a)
     71    ((_ a b)  (lex:seq a b))
     72    ((concatenation a b ...)
     73     (lex:seq a (concatenation b ...)))
     74    ))
     75   
    7376;; Alternatives (RFC 4234, Section 3.2)
    74 (define alternatives  lex:bar)
     77(define-syntax alternatives
     78  (syntax-rules ()
     79    ((_)      lex:pass)
     80    ((_ a)    a)
     81    ((_ a b)  (lex:bar a b))
     82    ((alternatives a b ...)
     83     (lex:bar a (alternatives b ...)))
     84    ))
    7585
    7686;; Value range alternatives (RFC 4234, Section 3.4)
     
    8090(define repetition lex:star)
    8191
    82 ;; convenience function for positive closure
     92;; Convenience function for positive closure
    8393(define repetition1 lex:pos)
    8494
    8595;;  Specific repetition (RFC 4234, Section 3.7)
    8696(define (repetition-n n p)
    87   (and (integer? n) (positive? n)
    88        (lex:bar (list-tabulate n (lambda (i) p)))))
     97  (let ((ps (list-tabulate n (lambda (i) p))))
     98    (lex:lst ps)))
    8999
    90100(define optional-sequence lex:opt)
     101
     102;; Matches a literal string (case-insensitive)
     103
     104(define (lit s)
     105  (let* ((f  (lambda (t) (lex:tok t (lex:try char-ci=?))))
     106        (ps (map f (if (string? s) (string->list s) s))))
     107    (lex:lst ps)))
    91108
    92109
     
    117134(define lf (char (integer->char 10)))
    118135
    119 
    120136;; Match the Internet newline \r\n.
    121137
    122 (define crlf (lex:seq (list cr lf)))
     138(define crlf (lex:seq cr lf))
    123139
    124140;; Match any US-ASCII control character. That is any character with a
     
    141157;; Match linear white space: *(WSP / CRLF WSP)
    142158
    143 (define lwsp (lex:star (lex:bar (list wsp (lex:seq (list crlf wsp))))))
     159(define lwsp (lex:star (lex:bar wsp (lex:seq crlf wsp))))
    144160
    145161
     
    160176;; quoted.
    161177
    162 (define quoted-pair (lex:seq (list (char #\\) (lex:bar (list vchar wsp)))))
     178(define quoted-pair (lex:seq (char #\\) (lex:bar vchar wsp)))
    163179
    164180;; Match a quoted string. The specials \ and " must be escaped inside
     
    167183(define char-set:quoted (char-set-complement (string->char-set "\\\"\r\n")))
    168184(define qtext (lex:set char-set:quoted))
    169 (define qcont (lex:bar (list (lex:pos qtext) quoted-pair)))
    170 
    171 (define quoted-string  (lex:seq (list dquote (lex:star qcont) dquote)))
     185(define qcont (lex:bar (lex:pos qtext) quoted-pair))
     186
     187(define quoted-string  (lex:seq dquote (lex:seq (lex:star qcont) dquote)))
    172188
    173189;;;; Additional convenience procedures and parser combinators
     
    181197
    182198(define (bind f p)
    183   (lambda (s)
    184     (let ((s1 (p s)))
    185       (match (lex:longest (p s))
    186              ((eaten food)
    187               (let ((x (f eaten)))
    188                 (and x `((,x ,food)))))
    189              (else #f)))))
     199  (lambda (a r s)
     200    (let ((a1 (lambda (s1)
     201                (match (lex:longest s1)
     202                       ((eaten food)
     203                        (let ((x (f eaten)))
     204                          (a `((,x ,food)))))
     205                       (else #f)))))
     206      (p a1 r s))))
    190207
    191208
     
    197214
    198215(define (drop-consumed p)
    199   (lambda (ss)
    200     (if (null? ss) ss
    201         (begin
    202           (let ((ss1 (map (lambda (s)
    203                             (match s ((eaten food)  (list (list (make-box eaten)) food))
    204                                    (else s)))
    205                           ss)))
    206             (match (lex:longest (p ss1))
    207                    ((eaten food) (let ((eaten1 (unbox (last eaten))))
    208                                    (list (list eaten1 food))))
    209                    (else #f)))))))
     216  (lambda (a r ss)
     217    (if (null? ss) (a ss)
     218        (let ((ss1 (map (lambda (s)
     219                          (match s ((eaten food)  (list (list (make-box eaten)) food))
     220                                 (else s)))
     221                        ss)))
     222          (match (lex:longest (p a r ss1))
     223                 ((eaten food) (let ((eaten1 (unbox (last eaten))))
     224                                 (a (list (list eaten1 food)))))
     225                 (else (r ss1)))))))
    210226
    211227(define (collect-chars . rest)
  • release/4/abnf/abnf.setup

    r14812 r14876  
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (compile -O -d2 -s abnf.scm -j abnf)
     6(compile -O -d2 -S -s abnf.scm -j abnf)
    77(compile -s abnf.import.scm)
    88
     
    1717
    1818  ;; Assoc list with properties for your extension:
    19   '((version 1.5)
     19  '((version 2.0)
    2020    (documentation "abnf.html")
    2121    ))
Note: See TracChangeset for help on using the changeset viewer.