;;;; Converts from infix to sexp. - Jeremy English
;;;;
;;;; A lisp version of the Crenshaw tutorials
;;;; 10-October-2006
;;;; http://compilers.iecc.com/crenshaw/tutor4.txt
;;;;
;;;; This one is similar to the interperter out of "Compiler
;;;; Construction" By Niklaus Wirth
;;;;
;;;; factor      = number | "(" expression ")" | variable
;;;; term        = factor {mulop factor}
;;;; expression  = term {addop term}
;;;; assignment  = variable "=" expression
;;;; statement   = assignment | expression
;;;; variable    = alpha {alpha | digit}
;;;; mulop       = "*"|"/"
;;;; addop       = "+"|"-"

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

(in-package :infix-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)
        (read-from-string (coerce token 'string)))
      (expected "integer")))

;;I don't care for the way that Crenshaw treats newlines and space
;;seperatly. I prefer the way Wirth handles it by skiping everything
;;less then space.
(defun is-white (char)
  (if (characterp char)
      (char<= char #\space)
      nil))

(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 factor (reader )
  (if (equal (sym reader) #\()
      (progn
        (match reader #\()
        (let ((value
               (expression reader )))
          (match reader #\))
          value))
      (if (alpha-char-p (sym reader))
          (get-name reader)
          (get-num reader))))

(defun expression (reader )
  (let ((value (term reader )))
    (loop while (is-add-op (sym reader)) do
          (cond
            ((equal (sym reader) #\+)
             (match reader #\+)
             (setf value (format nil "(+ ~a ~a)" value (term reader ))))
            ((equal (sym reader) #\-)
             (match reader #\-)
             (setf value (format nil "(- ~a ~a)"  value (term reader ))))))
    value))

(defun term (reader )
  (let ((value (factor reader)))
    (loop while (is-mul-op (sym reader)) do
          (cond
            ((equal (sym reader) #\*)
             (match reader #\*)
             (setf value (format nil "(* ~a ~a)" value (factor reader))))
            ((equal (sym reader) #\/)
             (match reader #\/)
             (setf value (format nil "(/ ~a ~a)" value (factor reader ))))))
    value))

(defun assignment (reader name )
  (match reader #\=)
  (format nil "(setf ~a ~a)" name (expression reader)))

(defun statement (reader)
  (if (alpha-char-p (sym reader))
      (let ((name (get-name reader)))
        (if (equal (sym reader) #\=)
            (assignment reader name)
            (expression reader)))
      (expression reader)))

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

(defun infix-sexp (exp)
  (let ((reader (closure-reader:define-string-reader exp)))
    (statement reader)))

(defun eval-infix-sexp (exp)
  (let ((reader (closure-reader:define-string-reader exp)))
    (eval (read-from-string (statement reader)))))