;;; Simple arithmetic expression compiler.
;;;
;;; This file is public domain.
;;;
;;; Intended for a shell command like
;;;     nightshade "1+2" -load ac.lisp
;;; which prints simple stack machine instructions that
;;; would evaluate the expression 1+2.
;;;
;;; `test-parser' contains examples of valid input.

(declaim (inline parse-char))

(defun parse-char (input)
  "Return a char read from INPUT."
  (read-char input ()))

(defun compile-term (input &optional (output *standard-output*))
  "Parse a term from INPUT, writing the associated assembly to OUTPUT.  A
   term is a lone number digit or a sequence of number digits with a * or a
   \ separating the digits."
  (flet ((output-number-or-group (number)
	   (if (char= number #\()
	       (or (char= (compile-expression input output) #\))
		   (error "Expected a closing parenthesis."))
	       (progn
		 (or (digit-char-p number) (error "Expected a digit."))
		 (format output "PUSH ~D~%" number)))))
    (let ((number (parse-char input)))
      (when number
	(output-number-or-group number)
	(loop for op = (parse-char input) while op do
	  (or (memq op '(#\* #\/))
	      (return-from compile-term op))
	  (let ((number (parse-char input)))
	    (or number
		(error "A number or group must follow a * or /."))
	    (output-number-or-group number)
	    (write-string (if (char= op #\*) "MUL" "DIV")
			  output)
	    (terpri output)))))))

(defun compile-expression (input &optional (output *standard-output*))
  "Parse an expression from INPUT, writing the associated assembly to
   OUTPUT.  An expression is a lone term or a sequence of terms with a + or
   a - separating the terms."
  (let ((op (compile-term input output)))
    (loop while op do
      (if (char= op #\))
	  ;; FIX throw error if like "1)"
	  (return-from compile-expression #\)))
      (or (memq op '(#\+ #\-))
	  (error "Terms must be separated by + or -."))
      (let ((next (compile-term input output)))
	;; FIX check that a term was written
	(write-string (if (char= op #\+) "ADD" "SUB") output)
	(setq op next))
      (terpri output))))


;;; Tests.

(defun test-compiler ()
  (flet ((test (expression result)
	   (with-input-from-string (input expression)
	     (let ((output (with-output-to-string (output)
			     (compile-expression input output))))
	       (or (string= output (format () result))
		   (error "Test fail: ~A (output was ~A)"
			  expression output))))))
    (test "1" "PUSH 1~%")
    (test "(1)" "PUSH 1~%")
    (test "(1+2)" "PUSH 1~%PUSH 2~%ADD~%")
    (test "1+2+3" "PUSH 1~%PUSH 2~%ADD~%PUSH 3~%ADD~%")
    (test "1+2*4" "PUSH 1~%PUSH 2~%PUSH 4~%MUL~%ADD~%")
    (test "(1+2)*4" "PUSH 1~%PUSH 2~%ADD~%PUSH 4~%MUL~%")
    (test "((1+2)*4)-7/2-1" "PUSH 1~%PUSH 2~%ADD~%PUSH 4~%MUL~%~
			     PUSH 7~%PUSH 2~%DIV~%SUB~%PUSH 1~%SUB~%")
    ;; Given examples.
    (test "3-2" "PUSH 3~%PUSH 2~%SUB~%")
    (test "1/5" "PUSH 1~%PUSH 5~%DIV~%")
    (test "((5-2)*3+7)*4"
	  "PUSH 5~%PUSH 2~%SUB~%PUSH 3~%MUL~%PUSH 7~%ADD~%PUSH 4~%MUL~%")
    (test "(1-(2-3)*9)/2"
	  "PUSH 1~%PUSH 2~%PUSH 3~%SUB~%PUSH 9~%MUL~%SUB~%PUSH 2~%DIV~%")
    (test "(9-(8-(7-(6-5))))"
	  "PUSH 9~%PUSH 8~%PUSH 7~%PUSH 6~%PUSH 5~%SUB~%SUB~%SUB~%SUB~%")
    ;; FIX Test errors.
    ;(test-error "()" "~%")
    ))

;;; Compile first program argument.
(with-input-from-string
    (input (or (car *command-line-words*)
	       (error "Expected an arithmetic expression as the first arg.")))
  (compile-expression input))
(quit)