Changeset 18684 in project


Ignore:
Timestamp:
07/03/10 07:04:54 (10 years ago)
Author:
Ivan Raikov
Message:

yet another improved approach to parametric lexgen

Location:
release/4/lexgen/branches
Files:
1 deleted
3 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/lexgen/branches/lexgen-typeclass/lexgen.meta

    r17313 r18684  
    1818 ; A list of eggs lexgen depends on.
    1919
    20  (needs )
     20 (needs typeclass)
    2121
    2222 (test-depends test)
  • release/4/lexgen/branches/lexgen-typeclass/lexgen.scm

    r18280 r18684  
    2323(module lexgen
    2424
    25   ( tok seq star star* bar redo
    26     try pass pos opt char
    27     set range lst lit
     25  ( seq star star* bar redo
     26    try pass pos opt lst
    2827    bind drop rebind
    29     longest lex stream-unfold )
     28
     29    longest lex
     30
     31    make-<Input> <Input>
     32    (Input->Token tok) <Token>
     33    (Token->CharLex char range set lit) <CharLex>
     34    )
    3035
    3136
     
    3338  (require-library srfi-1)
    3439  (import (only srfi-1 first second filter-map fold concatenate every lset<= ))
     40  (require-extension typeclass)
    3541
    3642;;
     
    7379;;
    7480
    75 ;; input stream comparison procedures
     81
     82;; input stream type class
     83
     84(define-class <Input>
     85  empty?
     86  head
     87  tail)
     88
     89
     90;; consumed stream comparison procedures
    7691
    7792(define (lst<= pred xx yy)
     
    93108(define (safe-car x) (and (pair? x) (car x)))
    94109
    95 ;; 'tok' builds a pattern matcher function that applies procedure p to
    96 ;; a given token and an input character. If the procedure returns a
    97 ;; true value, that value is prepended to the list of consumed
    98 ;; elements, and the input character is removed from the list of input
    99 ;; elements.
    100 
    101 (define (tok t p )
    102    (let ((f (lambda (s)
    103               (print "tok: s = " s)
    104               (let ((l (length s)))
    105                 (cond ((fx= l 2)
    106                        (let ((c (car s))
    107                              (u (cadr s)))
    108                          (and (pair? u)
    109                               (let ((ans (p t (car u))))
    110                                 (and ans (list (cons ans c) (cdr u)))))))
    111 
    112                        ((fx= l 3)
    113                         (let ((c (car s))
    114                               (u (cadr s))
    115                               (succ (caddr s)))
    116                           (print "u = " u)
    117                           (and (pair? u)
    118                                (let ((ans (p t (car u))))
    119                                  (and ans
    120                                       (let* ((u1   (cdr u))
    121                                              (dd   (print "u1 = " u1))
    122                                              (rest (or (and (pair? u1) u1)
    123                                                        (succ u1))))
    124                                         (cons (cons ans c) rest)))
    125                                  ))))
    126 
    127                      (else #f))))))
    128      (lambda (cont streams)
    129        (let ((streams1 (filter-map f streams)))
    130          (cont streams1)))))
    131    
    132110
    133111;; This matches a sequence of patterns.
     
    192170   
    193171
    194 ;; The rest of these are built from the previous five and are provided
    195 ;; for convenience.
    196 
    197172;; this parser always succeeds
    198173(define (pass cont s) (cont s))
     
    212187(define (try p) (lambda (x y) (let ((res (p x y))) (and res y))))
    213188
    214 ;; Matches a single character
    215 
    216 (define (char c) (tok c (try char=?)))
    217  
    218 ;; Matches any of a SRFI-14 set of characters.
    219 
    220 (define (set s)
    221   (let ((cs (if (char-set? s) s (list->char-set (if (string? s) (string->list s) s)))))
    222     (tok cs (try char-set-contains?))))
    223 
    224 ;; Range of characters. Analogous to character class '[]'
    225 
    226 (define (range a b)
    227   (if (char<? b a) (range b a)
    228       (set (ucs-range->char-set (char->integer a) (+ 1 (char->integer b))))))
    229189
    230190;; Matches a consecutive list of patterns
     
    236196            (else (loop (cdr ps) (seq (car ps) p1)))))))
    237197 
    238 ;; Matches a literal string s
    239 
    240 (define (lit s)
    241   (let ((f (lambda (t) (tok t (try char=?)))))
    242     (lst (map f (if (string? s) (string->list s) s)))))
    243198
    244199;; datatype used by bind and drop
     
    368323    (and res (list (reverse (first res)) (second res)))))
    369324
    370 
    371 
    372 ;; A helper procedure to transform streams from one format to
    373 ;; another. Procedure F must be a procedure of two arguments, a state
    374 ;; and a list of unconsumed characters. Procedure G is applied to an
    375 ;; unconsumed element, and is expected to return the original element
    376 ;; representation, before F was applied to the unconsumed stream.
    377 
    378 (define (stream-unfold init f g)
    379   (lambda (strm)
    380     (let ((l (length strm)))
    381       (cond ((fx= l 2)
    382              (let ((c (car strm))
    383                    (u (cadr strm)))
    384                (and (pair? u)
    385                     (let ((h (car u))
    386                           (r (cdr u)))
    387                       (letrec ((succ0 (lambda (r)
    388                                         (if (null? r) strm
    389                                             (let ((h1 (g (car r)))
    390                                                   (r1 (f (car r) (cdr r))))
    391                                               (list (cons h1 r1) succ0))))))
    392                         (list c (cons h (f init r)) succ0))))))
    393            
    394             ((fx= l 3)
    395              (let ((c (car strm))
    396                    (u (cadr strm))
    397                    (succ (caddr strm)))
    398                (and (pair? u)
    399                     (let ((h (car u))
    400                           (r (cdr u)))
    401                       (letrec ((succ0 (lambda (r)
    402                                         (if (null? r) strm
    403                                             (let ((h1 (g (car r)))
    404                                                   (r1 (f (car r) (succ (cdr r)))))
    405                                               (list (cons h1 r1) succ0))))))
    406                         (list c (cons h (f init r)) succ0))))))
    407            
    408            (else #f)))))
    409  
     325;; The following procedures are specific to the input class type
     326
     327(define-class <Token> (<Input> input)  tok)
     328
     329 
     330;; 'tok' builds a pattern matcher function that applies procedure p to
     331;; a given token and an input character. If the procedure returns a
     332;; true value, that value is prepended to the list of consumed
     333;; elements, and the input character is removed from the list of input
     334;; elements.
     335
     336(define=> (tok <Input>)
     337  (lambda (t p )
     338    (let ((f (lambda (s)
     339               (let ((c (car s))
     340                     (u (cadr s)))
     341                 (and (not (empty? u))
     342                      (let ((ans (p t (head u))))
     343                        (and ans (list (cons ans c) (tail u)))))
     344                 ))))
     345      (lambda (cont streams)
     346        (let ((streams1 (filter-map f streams)))
     347          (cont streams1))))))
     348 
     349(define (Input->Token I) (make-<Token> I (tok I)))
     350
     351(define-class <CharLex> (<Token> T)  char set range lit)
     352
     353
     354;; Matches a single character
     355
     356(define=> (char <Token>)
     357  (lambda (c) (tok c (try char=?))))
     358 
     359;; Matches any of a SRFI-14 set of characters.
     360
     361(define=> (set <Token>)
     362  (lambda (s)
     363    (let ((cs (if (char-set? s) s (list->char-set (if (string? s) (string->list s) s)))))
     364      (tok cs (try char-set-contains?)))))
     365
     366;; Range of characters. Analogous to character class '[]'
     367
     368(define=> (range <Token>)
     369  (letrec ((range0
     370            (lambda (a b)
     371              (if (char<? b a) (range0 b a)
     372                  (tok (ucs-range->char-set (char->integer a) (+ 1 (char->integer b)))
     373                       (try char-set-contains?))))))
     374    range0))
     375
     376;; Matches a literal string s
     377
     378(define=> (lit <Token>)
     379  (lambda (s)
     380    (let ((f (lambda (t) (tok t (try char=?)))))
     381      (lst (map f (if (string? s) (string->list s) s))))))
     382
     383
     384(define (Token->CharLex T)
     385  (make-<CharLex> T
     386                  (char T)
     387                  (set T)
     388                  (range T)
     389                  (lit T)
     390                  ))
    410391
    411392
  • release/4/lexgen/branches/lexgen-typeclass/tests/run.scm

    r18280 r18684  
    11
    2 (require-extension chicken lexgen srfi-1 srfi-14 test)
    3 
    4 
    5 (define a-pat (tok #\a (try char=?)))
    6 (define b-pat (tok #\b (try char=?)))
     2(require-extension typeclass lexgen srfi-1 srfi-14 test)
     3
     4
     5(define char-list-<Input>
     6  (make-<Input> null? car cdr))
     7
     8(define char-list-<Token>
     9  (Input->Token char-list-<Input>))
     10
     11(define char-list-<CharLex>
     12  (Token->CharLex char-list-<Token>))
     13
     14(import-instance (<Token> char-list-<Token> char-list/)
     15                 (<CharLex> char-list-<CharLex> char-list/))
     16
     17(define a-pat (char-list/tok #\a (try char=?)))
     18(define b-pat (char-list/tok #\b (try char=?)))
    719(define a-then-b-pat (seq a-pat b-pat))
    820(define a-or-b-pat (bar a-pat b-pat))
     
    1628(define a-b-opt-a-pat (seq a-pat (seq (opt b-pat) a-pat)))
    1729(define a-star-b-opt-pat (seq (star a-pat) (opt b-pat)))
    18 (define aabac-pat (lit "aabac"))
    19 (define aa-pat (lit "aa"))
    20 (define n4-pat (lst (list-tabulate 4 (lambda (i) (range #\0 #\9)))))
     30(define aabac-pat (char-list/lit "aabac"))
     31(define aa-pat (char-list/lit "aa"))
     32(define n4-pat (lst (list-tabulate 4 (lambda (i) (char-list/range #\0 #\9)))))
    2133
    2234(define abc-stream      (list `(() ,(string->list "abc"))))
     
    2638(define num-stream      (list `(() ,(string->list "1234"))))
    2739
     40
    2841(define (err s)
    2942  (print "lexical error on stream: " s)
     
    111124            )
    112125
    113 
    114126;; A pattern to match floating point numbers.
    115127;; "-"?(([0-9]+(\\.[0-9]+)?)|(\\.[0-9]+))([eE][+-]?[0-9]+)?
    116128
    117129(define numpat
    118   (let* ((digit        (range #\0 #\9))
     130  (let* ((digit        (char-list/range #\0 #\9))
    119131         (digits       (pos digit))
    120          (fraction     (seq (char #\.) digits))
     132         (fraction     (seq (char-list/char #\.) digits))
    121133         (significand  (bar (seq digits (opt fraction)) fraction))
    122          (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
    123          (sign         (opt (char #\-))))
     134         (exp          (seq (char-list/set "eE") (seq (opt (char-list/set "+-")) digits)))
     135         (sign         (opt (char-list/char #\-))))
    124136    (seq sign (seq significand (opt exp)))))
    125137
     
    158170
    159171(define bnumpat
    160   (let* ((digit        (range #\0 #\9))
     172  (let* ((digit        (char-list/range #\0 #\9))
    161173         (digits       (star digit))
    162          (fraction     (seq (char #\.) digits))
     174         (fraction     (seq (char-list/char #\.) digits))
    163175         (significand  (bar (seq digits (opt fraction)) fraction))
    164          (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
    165          (sign         (opt (char #\-)) )
     176         (exp          (seq (char-list/set "eE") (seq (opt (char-list/set "+-")) digits)))
     177         (sign         (opt (char-list/char #\-)) )
    166178         (pat          (seq (bind make-sign sign)
    167179                            (seq (bind make-significand (longest significand))
     
    181193;; Tokens with position information
    182194
     195       
    183196(define-record-type postok
    184197  (make-postok pos token)
     
    188201  )
    189202
     203(define pos? pair?)
     204(define pos-row car)
     205(define pos-col cdr)
     206(define make-pos cons)
     207
    190208(define-record-printer (postok x out)
    191209  (fprintf out "#<token ~A: ~A>"
    192210           (postok-pos x)
    193211           (postok-token x)))
    194 
    195 (define pos? pair?)
    196 (define pos-row car)
    197 (define pos-col cdr)
    198 (define make-pos cons)
    199 
    200 (define-record-type  stream-pos (stream-pos c rest)
    201   stream-pos?
    202   (c stream-pos-c)
    203   (rest stream-pos-rest ))
    204 
    205 ;; Converts an input stream to a stream with position information:
    206 
    207 (define (make-stream-pos begtok)
    208   (and (postok? begtok)
    209        (stream-unfold
    210         begtok
    211         (lambda (begtok strm)
    212 (print "begtok = " begtok)
    213 (print "strm = " strm)
     212         
     213(define (getpos p)
     214  (let ((f (lambda (in) (print "getpos: in = " in)
     215                   (and (pair? in) (postok-pos (car in)))))
     216        (g (lambda (i s) (list (make-postok i (car s))))))
     217    (rebind f g p)))
     218
     219(define pos-<Input>
     220  (let ((pos-tail
     221         (lambda (strm)
     222           (cond ((null? strm)   strm)
     223                 (else
     224                  (let* ((curtok  (car strm))
     225                         (dd      (print "curtok = " curtok))
     226                         (pos0    (postok-pos curtok))
     227                         (dd      (print "pos0 = " pos0))
     228                         (pos1    (let ((row0 (pos-row pos0))
     229                                        (col0 (pos-col pos0)))
     230                                    (case (cadr strm)
     231                                      ((#\newline)  (make-pos (+ 1 row0) 1))
     232                                      ((#\return)   (make-pos row0 1))
     233                                      (else         (make-pos row0 (+ 1 col0))))))
     234                         (res (cons (make-postok pos1 (cadr strm)) (cddr strm))))
     235                    (print "res = " res)
     236                    res)))))
     237        (pos-null? null?)
     238        (pos-head  (compose postok-token car)))
     239    (make-<Input> pos-null? pos-head pos-tail)))
     240
     241(define pos-<Token>
     242  (Input->Token pos-<Input>))
     243
     244(define pos-<CharLex>
     245  (Token->CharLex pos-<Token>))
     246
     247(import-instance (<Token> pos-<Token> pos/)
     248                 (<CharLex> pos-<CharLex> pos/))
     249
     250(define (make-pos-stream strm)
     251  (let ((begpos (make-pos 1 1)))
     252    (list `(() ,(cons (make-postok begpos (car strm)) (cdr strm))))))
    214253 
    215           (if (null? strm)
    216               '()
    217               (let* ((pos0 (postok-pos begtok))
    218                      (pos1 (let ((row0 (pos-row pos0))
    219                                  (col0 (pos-col pos0)))
    220                              (case (car strm)
    221                                ((#\newline)  (make-pos (+ 1 row0) 1))
    222                                ((#\return)   (make-pos row0 1))
    223                                (else         (make-pos row0 (+ 1 col0))))))
    224                      (res (stream-pos (make-postok pos1 (car strm)) (cdr strm))))
    225                 res)))
    226         postok-token)))
    227 
    228 (define begpos (make-pos 1 0))
    229 
    230 (define (getpos p)
    231   (let ((f (lambda (in) (print "in = " in)
    232                    (print "stream-pos-c (cdr in) = " (stream-pos-c (cdr in)))
    233                    (and (pair? in) (stream-pos? (cdr in))
    234                         (postok-pos (stream-pos-c (cdr in))))))
    235         (g (lambda (i s) (print "i = " i)
    236                    (print "s = " s)
    237                    (list (make-postok i (car s))))))
    238     (rebind f g p)))
    239 
    240254(define pos-numpat-stream
    241   (list ((make-stream-pos (make-postok begpos 'start))
    242          `(() ,(string->list "-123.45e-6")))))
     255  (make-pos-stream (string->list "-123.45e-6")))
    243256
    244257(define pbnumpat
    245   (let* ((digit        (range #\0 #\9))
     258  (let* ((digit        (pos/range #\0 #\9))
    246259         (digits       (star digit))
    247          (fraction     (seq (char #\.) digits))
     260         (fraction     (seq (pos/char #\.) digits))
    248261         (significand  (bar (seq digits (opt fraction)) fraction))
    249          (exp          (seq (set "eE") (seq (opt (set "+-")) digits)))
    250          (sign         (opt (char #\-)) )
     262         (exp          (seq (pos/set "eE") (seq (opt (pos/set "+-")) digits)))
     263         (sign         (opt (pos/char #\-)) )
    251264         (pat          (seq (getpos (bind make-sign sign))
    252265                            (seq (getpos (bind make-significand (longest significand)))
     
    254267    pat))
    255268
    256 (define (pos-num-parser s) (car (lex pbnumpat err s)))
    257 
    258 (pos-num-parser pos-numpat-stream)
     269(define (pos-num-parser s)  (car (lex pbnumpat err s)))
    259270
    260271(test-group "lexgen pos-num-parser test"
     
    265276                   (pos-num-parser pos-numpat-stream))
    266277            )
     278
Note: See TracChangeset for help on using the changeset viewer.