experiments/precedence-parsing.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 281 c0a3ded842df
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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