;;; -*- Mode:LISP; Package:SIM; Readtable:CL; Base:10 -*-

(defflavor sim-frame
           ()
           (tv:bordered-constraint-frame-with-shared-io-buffer)
           (:default-init-plist :panes
                                '((lisp lam:sensitive-lisp-listener
                                        :save-bits t)
                                  (display tv:window
					   :blinker-deselected-visibility :off
                                           :save-bits t))
                                :constraints
                                '((sim-frame (display lisp)
                                             ((display 6 :lines))
                                             ((lisp :even)))))
	   )


(defmethod (sim-frame :after :init) (&rest ignore)
  (send self :set-selection-substitute (send self :get-pane 'lisp)))

(tv:add-system-key #\1 'sim-frame "Simulator")

(defun display ()
  (let ((sup (send terminal-io :superior)))
    (cond ((typep sup 'sim-frame)
	   (send sup :get-pane 'display))
	  (t
	   terminal-io))))

(defun update-display ()
  (let* ((w (display))
	 (pc (proc-next-pc *proc*))
	 (inst (aref (proc-main-memory *proc*) (proc-pc *proc*))))
    (send w :clear-screen)
    (format w "PC=#o~o " pc)
    (format w "~s" (disassemble-inst inst))
    (format w "~&DEST=~o~20tSRC1=~o~40tSRC2=~o"
	    (get-dest inst)
	    (get-src-1 inst)
	    (get-src-2 inst))
    (format w "~&O=~o~20tA=~o~40tR=~o"
	    (proc-open-frame *proc*)
	    (proc-active-frame *proc*)
	    (proc-return-frame *proc*))
    (format w "~&Z~S N~S V~S C~S"
	    (proc-zero-bit *proc*)
	    (proc-sign-bit *proc*)
	    (proc-overflow-bit *proc*)
	    (proc-carry-bit *proc*))
    (when (not (zerop (proc-noop-next-bit *proc*)))
      (format w "~&NOOP"))
    ))



(defun setup ()
  (when (or (not (boundp '*proc*))
	    (null *proc*))
    (setq *proc* (new-proc 16. 256. (* 128. 256.)))
    (reset-proc-all *proc*)))

(defvar *get-next-command-unget* nil)

(defun unget-command (blip)
  (setq *get-next-command-unget* (append *get-next-command-unget* (list blip))))

(defun get-next-command ()
  (cond ((null *get-next-command-unget*)
	 (labels ((act-fun (char)
			   (or (ldb-test %%kbd-super char)
			       (member char '(#\/ #\tab #\space #\: #\altmode
					      #\@ #\linefeed #\^
					      )
				       :test 'char-equal))))
	   (do (command blip error-p)
	       (())
	     (multiple-value (command blip)
	       (with-input-editing (terminal-io
				     `((:activation ,#'act-fun)
				       (:preemptable)
				       (:full-rubout :full-rubout)
				       )
				     )
		 (do ((out-string (make-string 10. :fill-pointer 0))
		      (char (send terminal-io :any-tyi)
			    (send terminal-io :any-tyi)))
		     ((or (not (integerp char)
			       (characterp char)))
		      (values out-string char))
		   (array-push-extend out-string char))))
	     (cond ((eq blip :full-rubout)
		    (return :full-rubout))
		   ((consp command)
		    (case (car command)
		      (:typeout-execute
		       (case (cadr command)
			 (lam:force-object-kbd-input
			  (funcall (cadr command) (caddr command) terminal-io))))))
		   (t
		    (multiple-value (*command-prefix* error-p)
		      (ignore-errors (read-from-string command nil)))
		    (cond (error-p
			   (format t "?? error reading "))
			  (t
			   (when (not (member (cadr blip) '(#\linefeed) :test 'char-equal))
			     (format t "~c" (cadr blip)))
			   (return blip))))))))
	(t
	 (pop *get-next-command-unget*))))
	   

(defvar *accumulator*)
(defvar *command-prefix*)
(defvar *last-command*)
(defvar *update-display*)
(defvar *current-address*)

(defun sim ()
  (let ((*accumulator* 0)
	(*command-prefix* nil)
	(*update-display* t)
	(*read-base* 8)
	(*print-base* 8)
	(*last-command* nil)
	(*current-address* 0)
	)
    (command-loop)))

(defsignal bad-reg-adr error ())

(defun command-loop ()
  (format t "~&")
  (catch 'exit
    (do ()
	(())
      (condition-case (error)
	  (progn
	   (when *update-display*
	     (update-display)
	     (setq *update-display* nil))
	   (let ((blip (get-next-command)))
	     (cond ((eq blip :full-rubout)
		    (format t " ?? "))
		   (t
		    (let ((val (sim-eval *command-prefix*)))
		      (when (numberp val)
			(incf *accumulator* val)))
		    (when (consp blip)
		      (case (car blip)
			(:activation
			 (let* ((fun-name (format nil "SIM-~@:(~:C~)" (cadr blip)))
				(fun (intern-soft fun-name 'sim)))
			   (cond ((fboundp fun)
				  (funcall fun)
				  (setq *last-command* fun)
				  (when (not (memq fun '(sim-@ sim-space)))
				    (setq *accumulator* 0)))
				 (t
				  (format t "?? ~s " fun-name)))))))))))
	(bad-reg-adr
	 (format t "~&Error: ")
	 (send error :report terminal-io)
	 (format t "~&")
	 (setq *accumulator* 0))))))

(defun sim-space ()
  )

(defun sim-altmode ()
  (throw 'exit nil))

(defun sim-super-n ()
  (single-step)
  (setq *update-display* t))

(defun sim-@ ()
  (let ((blip (get-next-command)))
    (unget-command blip)
    (case *command-prefix*
      (G
       (setf (proc-next-pc *proc*) *accumulator*)
       (setf (proc-noop-next-bit *proc*) 1)
       (format t "~&")
       (setq *update-display* t))
      (t
       (let ((off (ra-command-to-address *command-prefix*)))
	 (cond ((null off)
		(format t "?? unknown base"))
	       (t
		(incf *accumulator* off))))))))

(defun sim-/ ()
  (format t " ")
  (setq *current-address* *accumulator*)
  (sim-print-ra-contents *current-address*))

(defun sim-print-ra-contents (adr)
  (cond ((< adr 0)
	 (let ((val (ra-read adr)))
	   (format t " ~o " val)))
	(t
	 (let ((val (aref (proc-main-memory *proc*) adr)))
	   (format t "~s " (disassemble-inst val))))))

(defun sim-line ()
  (incf *current-address*)
  (format t "~&")
  (cond ((< *current-address* 0)
	 (let ((info (ra-address-info *current-address*)))
	   (when (null info)
	     (ferror 'bad-reg-adr "unknown reg-adr ~o" *current-address*))
	   (format t "~&~o@~a/ "
		   (- *current-address* (car info))
		   (cadr info))))
	(t
	 (format t "~&~o/ " *current-address*)))
  (sim-print-ra-contents *current-address*))

(defun sim-^ ()
  (decf *current-address*)
  (format t "~&")
  (cond ((< *current-address* 0)
	 (let ((info (ra-address-info *current-address*)))
	   (when (null info)
	     (ferror 'bad-reg-adr "unknown reg-adr ~o" *current-address*))
	   (format t "~&~o@~a/ "
		   (- *current-address* (car info))
		   (cadr info))))
	(t
	 (format t "~&~o/ " *current-address*)))
  (sim-print-ra-contents *current-address*))

(defun sim-super-p ()
  (format t "--RUN--")
  (run)
  (format t "STOP~&")
  (setq *update-display* t))