Changeset 15973 in project


Ignore:
Timestamp:
09/20/09 04:59:06 (10 years ago)
Author:
Ivan Raikov
Message:

moved bind and drop procedures from abnf to lexgen

Location:
release/4
Files:
5 edited

Legend:

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

    r15802 r15973  
    6262(define pass lex:pass)
    6363
    64 (define (longest p)
    65   (lambda (cont s)
    66         (p (lambda (s1)
    67              (if (or (null? s1) (null? (cdr s1))) (cont s1)
    68                  (cont (list (lex:longest s1))))) s)))
    69 
    70 (define (bind f p)
    71     (lambda (cont ss)
    72       (let ((ss1 (map (lambda (s)
    73                        (match s
    74                               ((eaten food)  (list (list (make-box eaten)) food))
    75                               (else s)))
    76                      ss))
    77             (cont1 (lambda (ss)
    78                      (let ((ss1 (map (lambda (s)
    79                                        (match s ((eaten food)
    80                                                  (let* ((eaten0 (last eaten))
    81                                                         (eaten1 (drop-right eaten 1))
    82                                                         (x      (f eaten1)))
    83                                                    (let ((res (if x (list (append x (unbox eaten0)) food)
    84                                                                   (list (unbox eaten0) food))))
    85                                                      res)))
    86                                               (else s))) ss)))
    87                        (cont ss1)))))
    88         (p cont1 ss1))))
    89 
    90 
    91 (define-record-type box (make-box contents)
    92   box? (contents box-contents box-contents-set! ))
    93 
    94 (define box make-box)
    95 (define unbox box-contents)
    96 (define set-box! box-contents-set!)
    97 
    98 
    99 (define (drop-consumed p)
    100   (lambda (cont ss)
    101     (let* ((ss1 (map (lambda (s)
    102                        (match s
    103                               ((eaten food)  (list (list (make-box eaten)) food))
    104                               (else s)))
    105                      ss))
    106           (cont1  (lambda (ss)
    107                     (let ((ss1 (map (lambda (s)
    108                                       (match s
    109                                              ((eaten food) (let* ((eaten1 (unbox (last eaten)))
    110                                                                   (s1     (list eaten1 food)))
    111                                                              s1))
    112                                              (else s)))
    113                                     ss)))
    114                       (cont ss1)))))
    115       (p cont1 ss1))))
     64(define bind lex:bind)
     65(define drop-consumed lex:drop)
     66(define longest lex:longest)
    11667
    11768(define (memo p . rest)
     
    226177;; Match linear white space: *(WSP / CRLF WSP)
    227178
    228 (define lwsp (lex:star (lex:bar wsp (lex:seq (drop-consumed crlf) wsp))))
     179(define lwsp (lex:star (lex:bar wsp (lex:seq (lex:drop crlf) wsp))))
    229180
    230181
  • release/4/abnf/abnf.setup

    r15802 r15973  
    2121
    2222  ;; Assoc list with properties for your extension:
    23   '((version 2.3)
     23  '((version 2.4)
    2424    (documentation "abnf.html")
    2525    ))
  • release/4/lexgen/trunk/lexgen.scm

    r15779 r15973  
    4444    try pass pos opt char
    4545    set range lst lit
     46    bind drop
    4647    cps-table longest lex )
    4748
     
    166167    (lst (map f (if (string? s) (string->list s) s)))))
    167168
     169;; datatype used by bind and drop
     170(define-record-type box (make-box contents)
     171  box? (contents box-contents ))
     172
     173(define box make-box)
     174(define unbox box-contents)
     175
     176;; Given a list (X_1 ... X_n), returns a list ( (X_1 ... X_(n-1))  X_n )
     177(define-inline (split-at-last x)
     178  (if (null? x) (list (list) (list))
     179      (let loop ((prev (list (car x))) (rest (cdr x)))
     180        (cond ((null? rest)
     181               (list (reverse (cdr prev)) (car prev)))
     182              (else (loop (cons (car rest) prev) (cdr rest)))))))
     183
     184;; helpers for bind
     185(define-inline (bind-apply f)
     186  (lambda (s)
     187    (match s ((eaten food)
     188              (match-let (((eaten1 eaten0) (split-at-last eaten)))
     189                 (assert (box? eaten0))
     190                 (let* ((x   (f eaten1))
     191                        (res (if x (list (append x (unbox eaten0)) food)
     192                                 (list (unbox eaten0) food))))
     193                   res)))
     194           (else s))))
     195
     196;; Binds a procedure f to the consumed tokens returned by p
     197(define (bind f p)
     198    (lambda (cont ss)
     199      (let ((ss1 (map (lambda (s)
     200                       (match s
     201                              ((eaten food)  (list (list (box eaten)) food))
     202                              (else s)))
     203                     ss))
     204            (cont1 (lambda (ss)
     205                     (let ((ss1 (map (bind-apply f) ss)))
     206                       (cont ss1)))))
     207        (p cont1 ss1))))
     208
     209
     210(define (drop p)
     211  (bind (lambda x #f) p))
     212
    168213
    169214;; Takes the resulting streams produced by the application of a
     
    171216;; one exists.
    172217
    173 (define (longest streams)
     218(define-inline (longest0 streams)
    174219  (match-let (((count stream)
    175220               (fold (lambda (stream max)
     
    184229
    185230
     231(define (longest p)
     232  (lambda (cont s)
     233    (p (lambda (s1)
     234         (if (or (null? s1) (null? (cdr s1))) (cont s1)
     235             (cont (list (longest0 s1))))) s)))
     236
     237
    186238;; This takes a pattern and a string, turns the string into a list of
    187239;; streams (containing one stream), applies the pattern, and returns
     
    193245(define (lex pat error s)
    194246  (let* ((stream (->char-list s))
    195          (res    (longest (pat (lambda (s1) (if (null? s1) (error s) s1)) `((() ,stream))))))
     247         (res    (longest0 (pat (lambda (s1) (if (null? s1) (error s) s1)) `((() ,stream))))))
    196248    (and res (list (reverse (first res)) (second res)))))
    197 
    198249
    199250(define make-table      make-hash-table)
  • release/4/lexgen/trunk/lexgen.setup

    r15780 r15973  
    1717
    1818  ;; Assoc list with properties for your extension:
    19   '((version 2.5)
     19  '((version 2.6)
    2020    (documentation "lexgen.html")
    2121    ))
  • release/4/lexgen/trunk/tests/run.scm

    r14961 r15973  
    120120(test-group "lexgen numpat test"
    121121            (test (sprintf "match numpat on ~S" "-123.45e-6")
    122                    `((#\- #\1 #\2 #\3 #\. #\4 #\5 #\e #\- #\6) ()) (lex numpat err "-123.45e-6"))
     122                   `((#\- #\1 #\2 #\3 #\. #\4 #\5 #\e #\- #\6) ())
     123                   (lex numpat err "-123.45e-6"))
    123124            (test (sprintf "match numpat on ~S" "hi there")
    124125                  #f (lex numpat err "hi there")))
     126
    125127(define (->char-list s)
    126128  (if (string? s) (string->list s) s))
    127129
    128 (define (bind f p)
    129   (lambda (cont s)
    130     (let ((cont1
    131            (lambda (s1)
    132              (match (longest s1)
    133                     ((eaten food)
    134                      (let ((x (f eaten)))
    135                        (if x (cont `((,x ,food))) (cont `((,eaten ,food))))))
    136                     (else #f)))))
    137       (p cont1 s))))
    138            
    139130(define (collect cs)
    140131  (let loop ((cs cs) (ax (list)))
     
    144135
    145136(define (make-exp x)
    146   (or (and (pair? x) (let ((x1 (collect x)))
    147                        (cons `(exp ,(car x1)) (cdr x1)))) x))
     137  (or (and (pair? x)
     138           (let ((x1 (collect x)))
     139             (list `(exp . ,x1)))) x))
    148140
    149141(define (make-significand x)
    150   (or (and (pair? x) (let ((x1 (collect x)))
    151                        (cons `(significand ,(car x1)) (cdr x1)))) x))
     142  (or (and (pair? x)
     143           (let ((x1 (collect x)))
     144             (cons `(significand ,(car x1)) (cdr x1)))) x))
    152145
    153146(define (make-sign x)
    154   (or (and (pair? x) (let ((x1 (collect x)))
    155                        (cons `(sign ,(car x1)) (cdr x1)))) x))
     147  (or (and (pair? x)
     148           (let ((x1 (collect x)))
     149             (cons `(sign ,(car x1)) (cdr x1)))) x))
    156150
    157151(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))
     152
    158153
    159154(define (num-parser s)
     
    164159         (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
    165160         (sign         (opt (char #\-)) )
    166          (pat          (seq (bind make-sign sign) (seq (bind make-significand significand) (bind make-exp (opt exp))))))
    167     (reverse (car (longest (pat (check s) `((() ,(->char-list s)))))))))
     161         (pat          (seq (bind make-sign sign)
     162                            (seq (bind make-significand (longest significand))
     163                                 (bind make-exp (longest (opt exp)))))))
     164    (car (lex pat err s))))
    168165
     166(print (num-parser "-123.45e-6"))
    169167
    170168(test-group "lexgen num-parser test"
Note: See TracChangeset for help on using the changeset viewer.