author | Tony Garnock-Jones <tonyg@kcbbs.gen.nz> |
Tue, 11 Aug 2009 01:47:29 +0100 | |
changeset 281 | c0a3ded842df |
permissions | -rw-r--r-- |
281
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
1 |
(define table '((== non 4) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
2 |
(: right 5) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
3 |
(++ right 5) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
4 |
(+ left 6) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
5 |
(- left 6) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
6 |
(* left 7) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
7 |
(/ left 7))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
8 |
|
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
9 |
(define (parse exp) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
10 |
(define (p-op lhs exp min-precedence k) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
11 |
;;(write `(p-op ,lhs ,exp ,min-precedence)) (newline) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
12 |
(if (null? exp) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
13 |
(k lhs exp) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
14 |
(let ((op (car exp)) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
15 |
(rest0 (cdr exp))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
16 |
(cond |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
17 |
((assq op table) => |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
18 |
(lambda (entry) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
19 |
(let ((fixity (cadr entry)) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
20 |
(prec (caddr entry))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
21 |
(if (>= prec min-precedence) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
22 |
(p-val rest0 |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
23 |
(lambda (rhs rest) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
24 |
(let loop ((rhs rhs) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
25 |
(rest rest)) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
26 |
;;(write `(loop ,rhs ,rest)) (newline) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
27 |
(if (null? rest) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
28 |
(k `(,op ,lhs ,rhs) rest) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
29 |
(let ((lookahead (car rest))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
30 |
(cond |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
31 |
((assq lookahead table) => |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
32 |
(lambda (lentry) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
33 |
(let ((lfixity (cadr lentry)) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
34 |
(lprec (caddr lentry))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
35 |
(if (or (and (eq? lfixity 'right) (= lprec prec)) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
36 |
(> lprec prec)) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
37 |
(p-op rhs rest lprec loop) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
38 |
(p-op `(,op ,lhs ,rhs) rest min-precedence k))))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
39 |
(else (loop `(app ,rhs ,lookahead) (cdr rest)) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
40 |
;; (p-op rhs rest min-precedence |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
41 |
;; (lambda (v r) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
42 |
;; ;;(write `(loop-n ,v ,r)) (newline) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
43 |
;; (k `(,op ,lhs ,v) r))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
44 |
))))))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
45 |
(k lhs exp))))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
46 |
(else (p-op `(app ,lhs ,op) rest0 min-precedence k)))))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
47 |
|
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
48 |
(define (p-val exp k) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
49 |
(k (car exp) (cdr exp))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
50 |
|
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
51 |
(p-val exp (lambda (lhs rest) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
52 |
(p-op lhs rest 0 (lambda (result rest) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
53 |
(list 'result! result rest)))))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
54 |
|
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
55 |
(write (parse '(1 + 2 + 2.5 : 3 * 4 y z * 6 : a : b : c))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
56 |
;;(write (parse '(1 + 2 : 3 * 4 * 6 : foo))) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
57 |
(newline) |
c0a3ded842df
Trivial precedence parser
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
58 |