Pratt Parser in Arc

;=============================================================================
;  Pratt's Top Down Operator Precedence Parser
;=============================================================================
(def make-assoc (f)
  (fn (bind pre inf)
    (list bind (and pre (fn ()    (pre     (f bind))))
               (and inf (fn (val) (inf val (f bind)))))))

(= left  (make-assoc (fn (bind) (expression bind))))
(= right (make-assoc (fn (bind) (expression (- bind 1)))))

(def literal (x)
  (list 0 (fn () x) nil))

(def expression (bind)
  (withs (x    (car tokens)
          nud  (aand x (x 1) (it)))
    (zap cdr tokens)
    (while (and x (< bind (x 0)))
      (when (= x car.tokens)
        (zap cdr tokens)
        (zap (x 2) nud)))
    nud))

(mac infix (n parms . body)
  `(left ,n nil (fn ,parms ,@body)))

(mac prefix (n parms . body)
  `(left ,n (fn ,parms ,@body) nil))


;=============================================================================
;  ssexpand
;=============================================================================
(= ssyntax-rules* (obj #\~ (prefix 10 (r)  `(complement ,r))
                       #\: (infix 10 (l r) `(compose ,l ,r))
                       #\& (infix 10 (l r) `(andf ,l ,r))
                       #\. (infix 10 (l r) `(,l ,r))
                       #\! (infix 10 (l r) `(,l ',r))))

(def chars->value (x)
  (literal:read:string:rev x))

(def tokenize (x)
  ((afn (x l r)
     (aif (no x)
            (rev:cons chars->value.l r)
          (ssyntax-rules* car.x)
            (self cdr.x nil (cons it (cons chars->value.l r)))
          (self cdr.x (cons car.x l) r)))
   (coerce string.x 'cons) nil nil))

(def ssexpand (x)
  (= tokens tokenize.x)
  (expression -1))