Changeset 14886 in project


Ignore:
Timestamp:
06/05/09 06:55:31 (10 years ago)
Author:
Ivan Raikov
Message:

abnf bug fixes

File:
1 edited

Legend:

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

    r14878 r14886  
    4949         quoted-pair quoted-string
    5050
    51          bind drop-consumed collect-chars
     51         bind drop-consumed collect-chars longest memo
    5252         )
    5353
    5454   (import scheme chicken data-structures )
    5555
    56    (require-extension matchable srfi-1 srfi-14)
     56   (require-extension matchable srfi-1 srfi-14 srfi-69)
    5757
    5858   (require-library lexgen)
    5959   (import (prefix lexgen lex:))
     60
     61(define (longest p)
     62  (lambda (cont s)
     63        (p (lambda (s1)
     64             (if (or (null? s1) (null? (cdr s1))) (p cont s1)
     65                 (cont (list (lex:longest s1))))) s)))
     66
     67(define (bind f p)
     68    (lambda (cont s)
     69      (let ((cont1 (lambda (ss)
     70                     (let ((ss1 (map (lambda (s)
     71                                       (match s ((eaten food)
     72                                                 (let ((x (f eaten)))
     73                                                   (if x (list x food) s)))
     74                                              (else #f))) ss)))
     75                       (cont ss1)))))
     76        (p (if (null? s) cont cont1) s))))
     77
     78
     79(define-record-type box (make-box contents)
     80  box? (contents box-contents box-contents-set! ))
     81
     82(define box make-box)
     83(define unbox box-contents)
     84(define set-box! box-contents-set!)
     85
     86(define (drop-consumed p)
     87  (lambda (cont ss)
     88    (let* ((ss1 (map (lambda (s)
     89                       (match s
     90                              ((eaten food)  (list (list (make-box eaten)) food))
     91                              (else s)))
     92                     ss))
     93          (cont1  (lambda (ss)
     94                    (let ((ss1 (map (lambda (s)
     95                                      (match s
     96                                             ((eaten food) (let* ((eaten1 (unbox (last eaten)))
     97                                                                  (s1     (list eaten1 food)))
     98                                                             s1))
     99                                             (else s)))
     100                                    ss)))
     101                      (cont ss1)))))
     102      (p cont1 ss1))))
     103
     104(define (collect-chars . rest)
     105  (define (consumed-chars cs)
     106    (and (pair? cs)
     107         (let loop ((cs cs) (ax (list)))
     108           (cond ((null? cs)         (list ax))
     109                 ((char? (car cs))   (loop (cdr cs) (cons (car cs) ax)))
     110                 (else               (cons ax cs))))))
     111  (let-optionals rest ((kons #f))
     112    (let ((make (cond ((symbol? kons)     (lambda (x) `(,kons ,(car x))))
     113                      ((procedure? kons)  (lambda (x) (kons (car x))))
     114                      (else car))))
     115      (lambda (x)
     116        (let* ((x1   (consumed-chars x))
     117               (res  (and x1 (not (null? (car x1))) (cons (make x1) (cdr x1)))))
     118          res)))))
     119
     120(define (memo p . rest)
     121  (let-optionals rest ((reduce (lex:try <)))
     122    (lex:cps-table p reduce)))
    60123
    61124;;;; Terminal values (RFC 4234, Section 2.3)
     
    88151
    89152;; Repetition (RFC 4234, Section 3.6)
    90 (define repetition lex:star)
     153(define (repetition p)  (lex:star p))
    91154
    92155;; Convenience function for positive closure
     
    157220;; Match linear white space: *(WSP / CRLF WSP)
    158221
    159 (define lwsp (lex:star (lex:bar wsp (lex:seq crlf wsp))))
     222(define lwsp (lex:star (lex:bar wsp (lex:seq (drop-consumed crlf) wsp))))
    160223
    161224
     
    196259  (lex:set (string->char-set s)))
    197260
    198 (define (bind f p)
    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))))
    207 
    208 
    209 (define-record-type box (make-box contents)
    210   box? (contents box-contents ))
    211 
    212 (define box make-box)
    213 (define unbox box-contents)
    214 
    215 (define (drop-consumed p)
    216   (lambda (a r ss)
    217     (let* ((ss1 (map (lambda (s)
    218                        (match s
    219                               ((eaten food)  (list (list (make-box eaten)) food))
    220                               (else s)))
    221                      ss))
    222           (a1  (lambda (ss)
    223                    (a (map (lambda (s)
    224                              (match s
    225                                     ((eaten food) (let* ((eaten1 (unbox (last eaten)))
    226                                                          (s1     (list eaten1 food)))
    227                                                     s1))
    228                                     (else s)))
    229                            ss)))))
    230       (p a1 r ss1))))
    231 
    232 (define (collect-chars . rest)
    233   (define (consumed-chars cs)
    234     (and (pair? cs)
    235          (let loop ((cs cs) (ax (list)))
    236            (cond ((null? cs)         `(,ax))
    237                  ((char? (car cs))   (loop (cdr cs) (cons (car cs) ax)))
    238                  (else               (cons ax cs))))))
    239   (let-optionals rest ((kons #f))
    240     (let ((make (cond ((symbol? kons) (lambda (x) `(,kons ,(car x))))
    241                       ((procedure? kons) (lambda (x) (kons (car x))))
    242                       (else car))))
    243       (lambda (x)
    244         (let ((x1 (consumed-chars x)))
    245           (and x1 (cons (make x1) (cdr x1))))))))
    246 
    247261)
Note: See TracChangeset for help on using the changeset viewer.