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/lexgen-typeclass
Files:
1 edited
1 copied

Legend:

Unmodified
Added
Removed
  • 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.