;;A lisp version of the crenshaw tutorials - Jeremy English 10-October-2006
;;
;; <factor> ::= number | (<expression>) | <variable>
;; <expression> ::= <term> [<addop> <term>]*
;; <term> ::= <factor>  [ <mulop> <factor> ]*

(defpackage crenshaw-sexp
  (:use :cl :closure-reader))

(in-package :crenshaw-sexp)

(defun expected (s)
  (error (format nil "~a expected" s)))

(defun get-name (reader)
  (if (alpha-char-p (sym reader))
      (let ((token
             (loop while (and (not (null (sym reader)))
                              (alphanumericp (sym reader)))
                   collecting (char-upcase (sym reader))
                   do (next reader))))
        (skip-white reader)
        (coerce token 'string))
      (expected "name")))

(defun get-num (reader)
  (if (digit-char-p (sym reader))
      (let ((token
             (loop while (and (not (null (sym reader)))
                              (digit-char-p (sym reader)))
                   collecting (sym reader)
                   do (next reader))))
        (skip-white reader)
        (coerce token 'string))
      (expected "integer")))

(defun is-white (char)
  (member char '(#\tab #\space)))

(defun skip-white (reader)
  (loop while (is-white (sym reader))
        do (next reader)))

(defun is-add-op (char)
  (member char '(#\+ #\-)))

(defun is-mul-op (char)
  (member char '(#\* #\/)))

(defun ident (reader stream)
  (let ((name (get-name reader)))
    (if (equal (sym reader) #\()
        (progn
          (match reader #\()
          (match reader #\))
          (emit-ln stream "(funcall" name ")")))
        (emit-ln stream "(setf" "dx" name ")" )))

(defun factor (reader stream)
  (if (equal (sym reader) #\()
      (progn
        (match reader #\()
        (expression reader stream)
        (match reader #\)))
      (if (alpha-char-p (sym reader))
          (ident reader stream)
          (emit-ln stream "(setf" "dx" (get-num reader) ")"))))

(defun expression (reader stream)
  (if (is-add-op (sym reader)) ;Deal with unary minus by prefixing zero
      (emit-ln stream "(setf dx 0)")
      (term reader stream))
  (loop while (is-add-op (sym reader)) do
        (emit-ln stream "(push dx stack)")
        (cond
          ((equal (sym reader) #\+) (add reader stream))
          ((equal (sym reader) #\-) (subtract reader stream)))))

(defun term (reader stream)
  (factor reader stream)
  (loop while (is-mul-op (sym reader)) do
        (emit-ln stream "(push dx stack)")
        (cond
          ((equal (sym reader) #\*) (multiply reader stream))
          ((equal (sym reader) #\/) (divide reader stream)))))

(defun add (reader stream)
  (match reader #\+)
  (term reader stream)
  (emit-ln stream "(setf dx (+ dx (pop stack)))"))

(defun subtract (reader stream)
  (match reader #\-)
  (term reader stream)
  (emit-ln stream "(setf dx (* -1 (- dx (pop stack))))"))

(defun multiply (reader stream)
  (match reader #\*)
  (factor reader stream)
  (emit-ln stream "(setf dx (* (pop stack) dx))"))

(defun divide (reader stream)
  (match reader #\/)
  (factor reader stream)
  (emit-ln stream "(setf dx (/ (pop stack) dx))"))

(defun match (reader x)
  (if (equal x (sym reader))
      (progn
        (next reader)
        (skip-white reader))
      (expected (format nil "~a" x))))

(defun emit (s body)
  (mapcar #'(lambda (x)
              (format s "~a " x))
          (cons #\tab body)))

(defun emit-ln (s &rest body)
  (emit s body)
  (format s "~a" #\newline))

(defun infix-calc (exp &key (dump nil))
  (let ((s (make-string-output-stream))
        (reader (closure-reader:define-string-reader exp)))
    (write-string "(let ((dx 0) (stack '()))" s)
    (expression reader s)
    (write-string "dx)" s)
    (let ((sexp (read-from-string (get-output-stream-string s))))
      (if dump sexp (eval sexp)))))