(defpackage :nonamelang
  (:shadow
   #:eval))

(in-package :nonamelang)

(defvar *stack* nil)
(defvar *global* (make-hash-table :test 'eq))

(defun eval (proc)
  (do ()
      ((null proc))
    (labels ((invoke (next-proc)
               (cond ((null proc)
                      ;; This is a tail call, just loop by setting our current proc to the
                      ;; one to invoke.
                      (setq proc next-proc))
                     (t
                      ;; No luck, must recurse
                      (eval next-proc)))))
      (let ((word (pop proc)))
        (case word
          ((+ * / - mod rem floor ceiling logior logxor lognot logand
              eq eql equal = < > <= >= /=
              rplaca rplacd cons)
           (multiple-value-bind (b a)
               (values (pop *stack*) (pop *stack*))
             (push (funcall word a b) *stack*)))
          ((atom consp car cdr symbolp numberp
                 princ prin1 print)
           (push (funcall word (pop *stack*)) *stack*))
          ((print-stack)
           (print `(stack = ,*stack*)))
          ((drop) (pop *stack*))
          ((nth)  (push (nth (pop *stack*) *stack*) *stack*))
          ((swap) (rotatef (car *stack*) (cadr *stack*)))
          ((if)
           (multiple-value-bind (cons cond) (values (pop *stack*) (pop *stack*))
             (when cond (invoke cons))))
          ((ifelse)
           (multiple-value-bind (alt cons cond) (values (pop *stack*) (pop *stack*) (pop *stack*))
             (invoke (if cond cons alt))))
          ((eval)
           (invoke (pop *stack*)))
          ((def)
           (multiple-value-bind (body name) (values (pop *stack*) (pop *stack*))
             (setf (gethash name *global*) body)))
          (t
           (cond ((and word (symbolp word))
                  (multiple-value-bind (value win)
                      (gethash word *global*)
                    (unless win
                      (error "Undefined word: ~S" word))
                    (invoke value)))
                 ((and (consp word) (eq (car word) 'quote))
                  (push (cadr word) *stack*))
                 (t
                  (push word *stack*)))))))))

(defun reset ()
  (clrhash *global*)
  (setq *stack* nil)
  (eval '('dup (0 nth) def))
  (eval '('square (dup *) def))
  (eval '('dotimes
          (dup 0 >
           (dup 2 nth 
            eval
            -1 +
            dotimes)
           (drop drop)
           ifelse)
          def))
  (eval '((print drop) 100 dotimes))
  *stack*)