;; RPN evaluator from LL(1) tool

(def-ll1 *forth-grammar*
  (S  (S1 eof)  %0)
  (S1 (int S0)  (funcall %1 %0))
  (S0 (S1 F S0) #'(lambda (arg1) (funcall %2 (funcall %1 arg1 %0))))
  (S0 ()        #'(lambda (arg1) arg1))
  (F  (+)       #'+)
  (F  (*)       #'*))

(defun forth-eval (l)
  (setf (ll1-parser-lookahead *forth-grammar*)
        #'(lambda () 
            (cond ((null l)          'eof)
                  ((numberp (car l)) 'int) 
                  (t                 (car l)))))
  (setf (ll1-parser-get-token *forth-grammar*) 
        #'(lambda () (pop l)))
  (parse-ll1 *forth-grammar*))

(forth-eval '(1 4 * 1 + 7 + 1 2 + *))


;; Hand-coded recursive-descent evaluator

(defun forth-eval-2 (l)
  (labels 
      ((peek ()  (if (numberp (car l)) 
                     'int 
                     (car l)))
       (eat (c)  (if (eq c (peek)) 
                     (pop l) 
                     (error "Error at ~s~%" l)))
       (S1 ()    (S0 (eat 'int)))
       (S0 (v)   (if (eq (peek) 'int) 
                     (let ((v2 (S1))
                           (op (F)))
                       (S0 (funcall op v v2)))
                     v))
       (F ()     (if (member (peek) '(+ *))
                     (symbol-function (pop l))
                     (error "Error at ~s~%" l))))
    (S1)))


;; LR(1) parser using Johnson's YACC

(def-jyacc lr-forth
  (S (S S +) (+ %0 %1))
  (S (S S *) (* %0 %1))
  (S (int)   %0))

(defun forth-eval-3 (tokens)
  (labels 
      ((next () (let ((h (pop tokens)))
                  (cond ((null h)        '(*eof* . *eof*))
                        ((numberp h)     `(int . ,h))
                        (t               `(,h . ,h)))))
       (err ()  (format t "Error at ~s~%" tokens)))
    (lr-forth #'next #'err)))


;; Hand-coded RPN evaluator

(defun forth-eval-4 (l)
  (let ((stack nil)
        (e nil))
    (labels 
     ((fpop () (assert stack nil "Empty stack at ~s" l) (pop stack)))
     (while l
       (setf e (pop l))
       (cond ((numberp e) (push e stack))
             ((eq e '+)   (push (+ (fpop) (fpop)) stack))
             ((eq e '*)   (push (* (fpop) (fpop)) stack)))))
    (assert (eq 1 (length stack)) nil "Final stack should be size 1")
    (pop stack)))