1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/experiments/precedence-parsing.scm	Sat Oct 08 15:36:03 2011 -0400
     1.3 @@ -0,0 +1,58 @@
     1.4 +(define table '((== non 4)
     1.5 +		(: right 5)
     1.6 +		(++ right 5)
     1.7 +		(+ left 6)
     1.8 +		(- left 6)
     1.9 +		(* left 7)
    1.10 +		(/ left 7)))
    1.11 +
    1.12 +(define (parse exp)
    1.13 +  (define (p-op lhs exp min-precedence k)
    1.14 +    ;;(write `(p-op ,lhs ,exp ,min-precedence)) (newline)
    1.15 +    (if (null? exp)
    1.16 +	(k lhs exp)
    1.17 +	(let ((op (car exp))
    1.18 +	      (rest0 (cdr exp)))
    1.19 +	  (cond
    1.20 +	   ((assq op table) =>
    1.21 +	    (lambda (entry)
    1.22 +	      (let ((fixity (cadr entry))
    1.23 +		    (prec (caddr entry)))
    1.24 +		(if (>= prec min-precedence)
    1.25 +		    (p-val rest0
    1.26 +			   (lambda (rhs rest)
    1.27 +			     (let loop ((rhs rhs)
    1.28 +					(rest rest))
    1.29 +			       ;;(write `(loop ,rhs ,rest)) (newline)
    1.30 +			       (if (null? rest)
    1.31 +				   (k `(,op ,lhs ,rhs) rest)
    1.32 +				   (let ((lookahead (car rest)))
    1.33 +				     (cond
    1.34 +				      ((assq lookahead table) =>
    1.35 +				       (lambda (lentry)
    1.36 +					 (let ((lfixity (cadr lentry))
    1.37 +					       (lprec (caddr lentry)))
    1.38 +					   (if (or (and (eq? lfixity 'right) (= lprec prec))
    1.39 +						   (> lprec prec))
    1.40 +					       (p-op rhs rest lprec loop)
    1.41 +					       (p-op `(,op ,lhs ,rhs) rest min-precedence k)))))
    1.42 +				      (else (loop `(app ,rhs ,lookahead) (cdr rest))
    1.43 +					    ;; (p-op rhs rest min-precedence
    1.44 +;; 						  (lambda (v r)
    1.45 +;; 						    ;;(write `(loop-n ,v ,r)) (newline)
    1.46 +;; 						    (k `(,op ,lhs ,v) r)))
    1.47 +					    )))))))
    1.48 +		    (k lhs exp)))))
    1.49 +	   (else (p-op `(app ,lhs ,op) rest0 min-precedence k))))))
    1.50 +
    1.51 +  (define (p-val exp k)
    1.52 +    (k (car exp) (cdr exp)))
    1.53 +
    1.54 +  (p-val exp (lambda (lhs rest)
    1.55 +	       (p-op lhs rest 0 (lambda (result rest)
    1.56 +				  (list 'result! result rest))))))
    1.57 +
    1.58 +(write (parse '(1 + 2 + 2.5 : 3 * 4 y z * 6 : a : b : c)))
    1.59 +;;(write (parse '(1 + 2 : 3 * 4 * 6 : foo)))
    1.60 +(newline)
    1.61 +