;; HW solution
;;
;; My original grammar attempt looked something like
;;   S -> P op
;;   S -> int
;;   P -> P swap
;;   P -> P S op
;;   P -> S S
;;
;; But this turns out not to work, because it doesn't allow sequences
;; like
;;
;;   1 2 swap 3 - +
;;
;; since the grammar doesn't know what to do with P S swap.  One could
;; try to introduce another nonterminal for a collection of three things,
;; but then there is a sort of infinite regress: if I have a symbol P_n
;; which represents n things on the stack, then I would need something like
;; 
;;   P_n+1 -> P_n S swap
;;
;; which gives an infinite number of productions.  A more natural way to
;; handle this problem is to not try to encode length information into the
;; grammar at all, but to treat it as an attribute which can be checked.
;; This is what I've done below.

(def-jyacc lr-forth
  (stack1 (stack)      (forth-get-last %0))
  (stack  (stack int)  (push %1 %0))
  (stack  (stack op)   (forth-op %1 %0))
  (stack  (stack swap) (forth-swap %0))
  (stack  ())
  (op (+)    #'+)
  (op (-)    #'-)
  (op (*)    #'*))

(defun forth-op (op stack)
  (let ((y (pop stack))
        (x (pop stack)))
    (unless (and x y) (error "Stack underflow."))
    (push (funcall op x y) stack)
   stack))

(defun forth-swap (stack)
  (let ((y (pop stack))
        (x (pop stack)))
    (unless (and x y) (error "Stack underflow."))
    (push y stack)
    (push x stack)
    stack))

(defun forth-get-last (stack)
  (unless (equal 1 (length stack)) (error "Stack should be length 1."))
  (pop stack))

(defun forth-eval (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)))