smalltalk-tng
view experiments/precedence-parsing.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | |
| children |
line source
1 (define table '((== non 4)
2 (: right 5)
3 (++ right 5)
4 (+ left 6)
5 (- left 6)
6 (* left 7)
7 (/ left 7)))
9 (define (parse exp)
10 (define (p-op lhs exp min-precedence k)
11 ;;(write `(p-op ,lhs ,exp ,min-precedence)) (newline)
12 (if (null? exp)
13 (k lhs exp)
14 (let ((op (car exp))
15 (rest0 (cdr exp)))
16 (cond
17 ((assq op table) =>
18 (lambda (entry)
19 (let ((fixity (cadr entry))
20 (prec (caddr entry)))
21 (if (>= prec min-precedence)
22 (p-val rest0
23 (lambda (rhs rest)
24 (let loop ((rhs rhs)
25 (rest rest))
26 ;;(write `(loop ,rhs ,rest)) (newline)
27 (if (null? rest)
28 (k `(,op ,lhs ,rhs) rest)
29 (let ((lookahead (car rest)))
30 (cond
31 ((assq lookahead table) =>
32 (lambda (lentry)
33 (let ((lfixity (cadr lentry))
34 (lprec (caddr lentry)))
35 (if (or (and (eq? lfixity 'right) (= lprec prec))
36 (> lprec prec))
37 (p-op rhs rest lprec loop)
38 (p-op `(,op ,lhs ,rhs) rest min-precedence k)))))
39 (else (loop `(app ,rhs ,lookahead) (cdr rest))
40 ;; (p-op rhs rest min-precedence
41 ;; (lambda (v r)
42 ;; ;;(write `(loop-n ,v ,r)) (newline)
43 ;; (k `(,op ,lhs ,v) r)))
44 )))))))
45 (k lhs exp)))))
46 (else (p-op `(app ,lhs ,op) rest0 min-precedence k))))))
48 (define (p-val exp k)
49 (k (car exp) (cdr exp)))
51 (p-val exp (lambda (lhs rest)
52 (p-op lhs rest 0 (lambda (result rest)
53 (list 'result! result rest))))))
55 (write (parse '(1 + 2 + 2.5 : 3 * 4 y z * 6 : a : b : c)))
56 ;;(write (parse '(1 + 2 : 3 * 4 * 6 : foo)))
57 (newline)