;;; -*- Mode:LISP; Package:USER; Base:10 -*-

(defmacro defsynonym (name1 name2)
  `(DEFMACRO ,name1 (&REST ARGS)
     (CONS (QUOTE ,name2) ARGS)))

(defsynonym null? null)
(defsynonym symbol? symbolp)

(defmacro defmsg (name &optional (message name))
  `(SETF (FUNCTION ,name) (INTERNAL-OPERATION (QUOTE ,message))))

(defun internal-operation (message)
  (lambda (object &rest args)
    (apply (funcall object message) args)))

(defstruct (monitored-stack
	     (:conc-name monitored-stack-)
	     (:predicate nil)
	     )
  (current-depth 0)
  (maximum-depth 0)
  (number-of-pushes 0)
  (stack-list '()))

(defun stack-initialize (stack)
  (setf (monitored-stack-current-depth stack) 0)
  (setf (monitored-stack-maximum-depth stack) 0)
  (setf (monitored-stack-number-of-pushes stack) 0)
  (setf (monitored-stack-stack-list stack) '()))

(defun stack-statistics (stack)
  (format nil "Total pushes: ~D  Maximum depth: ~D  "
	  (monitored-stack-number-of-pushes stack)
	  (monitored-stack-maximum-depth stack)))

(defun stack-push (value stack)
  (incf (monitored-stack-number-of-pushes stack))
  (incf (monitored-stack-current-depth stack))
  (when (> (monitored-stack-current-depth stack)
	   (monitored-stack-maximum-depth stack))
    (setf  (monitored-stack-maximum-depth stack)
	   (monitored-stack-current-depth stack)))
  (push value (monitored-stack-stack-list stack)))

(defun stack-pop (stack)
  (decf (monitored-stack-current-depth stack))
  (pop (monitored-stack-stack-list stack)))

	


(defun build-register-array (register-list)
  (let ((register-array (make-array (length register-list))))
    (labels
      ((register-index (register-name)
	  (or (position register-name register-list)
	      (ferror "There is no register named ~S." register-name)))

       (fetch (register)
	  (aref register-array (register-index register)))

       (assign! (register new-value)
	  (setf (aref register-array (register-index register)) new-value))

       (compiled-fetch (register)
	  `(AREF ,register-array ,(register-index register)))

       (compiled-assign! (register)
	  `(LAMBDA (NEW-VALUE)
	     (ASET NEW-VALUE ,register-array ,(register-index register))))
       
       (dispatch (operation)
	 (case operation
	   (fetch-register #'fetch)
	   (assign-register! #'assign!)
	   (compiled-fetch #'compiled-fetch)
	   (compiled-assign! #'compiled-assign!)
	   (otherwise (ferror "No such operation ~S" operation))))
       )
      (compile-lambda #'dispatch))))

(defmsg fetch-register)
(defmsg assign-register!)
(defmsg compiled-fetch)
(defmsg compiled-assign!)

	 
(defun build-register-machine (registers controller)
  (let ((register-array (build-register-array registers)))
    (cons register-array (compile-controller register-array controller))))

(defsynonym machine-registers car)
(defsynonym machine-controller cdr)

(defun run-machine (machine)
  (funcall (machine-controller machine)))

(defun scan-for-labels (controller)
  (do ((controller-tail controller (cdr controller-tail))
       (labels '()
	 (let ((possible-label (car controller-tail)))
	   (if (symbol? possible-label)
	       (cons possible-label labels)
	       labels))))
      ((null? controller-tail) labels)))
	   

(defun compile-controller (register-array controller)
  (let ((label-list (scan-for-labels controller)))
    (let ((label-array (make-array (length label-list)))
	  compilers)
      (labels
	(
	 (assign-label! (label code)
	    (aset code label-array (position label label-list)))

	 (compile-stuff (stuff)
	    (if (null? stuff)
		'(lambda () 'done)
	        (let ((instruction (car stuff))
		      (tail (compile-stuff (cdr stuff))))
		  (if (symbol? instruction)
		      (compile-label instruction tail)
		      (compile-instruction instruction tail)))))

	 (compile-label (label controller-tail)
	    (assign-label! label controller-tail)
	    controller-tail)

	 (compile-instruction (instruction tail)
	    (let ((handler (cdr (assq (car instruction) compilers))))
	      (if (null? handler)
		  (ferror "There is no such kind of instruction: " (car instruction))
		  (compile-lambda
		    `(LAMBDA ()
		       ,(apply handler tail (cdr instruction)))))))

	 (falling-through (compiled-tail new-instruction)
	    `(PROGN ,new-instruction
		    (FUNCALL ,compiled-tail)))

	 (compile-assign (tail register value)
	    (falling-through tail
		`(,(compiled-assign! register-array register)
		  ,(compile-argument value))))

	 (compile-argument (arg)
	    `(quote (compiled-argument ,arg)))

	 )
	(setf compilers
	      `((ASSIGN . ,#'compile-assign)
		;;(GOTO . ,#'compile-goto)
		;;(BRANCH . ,#'compile-branch)
		;;(PERFORM . ,#'compile-perform)
		))
	(compile-stuff controller)))))