;;; general helpers

(defmacro putprop (sym val indicator)
  `(setf (get ,sym ,indicator) ,val))

(defmacro defprop (sym val indicator)
  (cond ((and (listp val) (eq (car val) 'lambda))
	 `(setf (get ',sym ',indicator) #',val))
	(t `(setf (get ',sym ',indicator) ',val))))

(defun aget (alist key)
  (cdr (assoc key alist)))

(defun nzerop (number) (not (zerop number)))

;;; constant folder

(defvar *bindings*)

(defun reset-bindings ()
  (setq *bindings* '((nil . nil)
		     (t . t))))

(defun set-bindings (bindings)
  (reset-bindings)
  (setq *bindings* (append *bindings* bindings)))

(defun lookup (name)
  (let ((val (assoc name *bindings*)))
    (if val
	(cdr val)
	name)))

(defun true (x) (eq x t))

(defun c-false (x)
  (or (null x)
      (and (numberp x) (zerop x))))

(defun not-p (e)
  (and (listp e) (eq (car e) '!)))

(defun tobool-p (e)
  (and (listp e) (eq (car e) '!) (eq (caadr e) '!)))

(defun tobool (e)
  (cond ((c-false e) nil)
	((true e) t)
	((not-p e) e)
	(t `(! (! ,e)))))

(defmacro defop (sym c-sym arity args &rest body)
  `(progn
    (setf (get ',sym 'c-op) (lambda ,args ,@body))
    (setf (get ',c-sym 'c-arity) ',arity)))

(defop and && binary (args)
  (let ((args (remove-if #'true args)))
    (cond ((null args) t)
	  ((some #'c-false args) nil)
	  ((null (cdr args)) (tobool (car args)))
	  (t (cons '&& args)))))

(defop or |||| binary (args)
  (let ((args (remove-if #'null args)))
    (cond ((null args) nil)
	  ((some #'true args) t)
	  ((null (cdr args)) (tobool (car args)))
	  (t (cons '|||| args)))))

(defop ! ! unary (args)
  (let ((arg (car args)))
    (cond ((null arg) t)
	  ((true arg) nil)
	  ((tobool-p arg)
	   (cadr arg))
	  (t (cons '! args)))))

(defop logand & binary (args)
  (cond ((some #'zerop args) 0)
	((every #'numberp args) (apply #'logand args))
	(t (cons '& args))))

(defop = = binary (args)
  (if (every #'numberp args)
      (apply #'= args)
      (cons '= args)))

(defop != != binary (args)
  (if (every #'numberp args)
      (apply #'/= args)
      (cons '!= args)))

(defun xeval (e)
  (let (f)
    (cond ((numberp e) e)
	  ((atom e) (lookup e))
	  ((and (atom (car e))
		(setq f (get (car e) 'c-op)))
	   (funcall f (mapcar #'xeval (cdr e))))
	  (t e))))

;;; C output

(defun sym-to-c (sym)
  (substitute #\_ #\- (string sym)))

(defun xpr-to-c (e)
  (cond ((numberp e)
	 (format nil "0~A" e))
	((symbolp e)
	 (let ((idx (get e 'idx)))
	   (if idx
	       (format nil "~A[~A]" (sym-to-c e) (xpr-to-c idx))
	       (format nil "~A" (sym-to-c e)))))
	((eq (get (car e) 'c-arity) 'unary)
	 (format nil "(~A~A)" (string (car e)) (xpr-to-c (cadr e))))
	;; TODO: check that we only have 3 elements in the list
	((eq (get (car e) 'c-arity) 'binary)
	 (format nil "(~A ~A ~A)"
		 (xpr-to-c (cadr e))
		 (string (car e))
		 (xpr-to-c (caddr e))))
	;; this shouldn't happen
	(t (format nil "{~A}" e))))

(defun input-to-c (elt)
  (let ((input (get elt 'input))
	(op (get elt 'op)))
    (if op
	(format nil "~A(~{~A~^, ~})" (xpr-to-c op) (mapcar #'xpr-to-c input))
	(xpr-to-c input))))

;;;

(setq *read-base* 8.
      *print-base* 8.)

(defun get-lines (filename)
  (with-open-file (*standard-input* filename)
    (do ((l (read-line nil nil) (read-line nil nil))
	 (lines nil (nconc lines (list l))))
	((null l) lines))))

(defun valid-line-p (line)
  (and (not (string-equal line ""))
       (digit-char-p (char line 0))))

(defun split-fields (line)
  (with-input-from-string (*standard-input* line)
    (do ((f (read nil nil) (read nil nil))
	 (fields nil (nconc fields (list f))))
	((null f) fields))))

(defconstant +fields+ '(FLOW STATE ADR CLK CIR WR CB CD CBA BUS DAD SPS ALU SBC SBM SDM SBA UBF SRX RIF UPF))

(defparameter *lines* (remove-if-not #'valid-line-p (get-lines "ucode_40.txt")))

(defparameter *words* (mapcar #'(lambda (line) (pairlis +fields+ (split-fields line))) *lines*))

(defun find-word (name)
  (find-if #'(lambda (word) (eq (cdr (assoc 'state word)) name)) *words*))

(defvar *registers* nil)
(defvar *combiners* nil)
(defvar *dad*)

(defun set-input (elt input)
  (putprop elt input 'input)
  (putprop elt t 'dirtyp)
  (remprop elt 'op))

(defun dirtyp (elt)
  (and (symbolp elt)
       (get elt 'dirtyp)))

(defun def-reg (reg input)
  (putprop reg t 'regp)
  (set-input reg input)
  (push reg *registers*))

(defun def-comb (comb)
  (putprop comb nil 'regp)
  (set-input comb nil)
  (push comb *combiners*))

(defun def-registers ()
  (setq *registers* nil)
  (def-reg 'b 'dmux)
  (def-reg 'r 'dmux)
  (def-reg 'ir 'dmux)
  (def-reg 'd 'alu)
  (def-reg 'ba 'bamux)
  (setq *registers* (reverse *registers*)))

;;; combinational logic elements have to be
;;; sorted by dependency
(defun def-combiners ()
  (setq *combiners* nil)
  (mapc #'def-comb '(rd bc bmux cin alu dmux bamux))
  (setq *combiners* (reverse *combiners*)))

(def-registers)
(def-combiners)

(defun mark-all-dirty ()
  (dolist (r (append *registers* *combiners*))
    (putprop r t 'dirtyp)))

(defun mark-all-regs-clean ()
  (dolist (r *registers*)
    (putprop r nil 'dirtyp)))

(defun mark-all-dirty-from-inputs ()
  (dolist (c *combiners*)
    (let ((input (get c 'input)))
      (and (or (and (atom input) (dirtyp input))
	       (and (listp input) (some #'dirtyp input)))
	   (putprop c t 'dirtyp)))))


(defun update-r ()
  (let ((srx (lookup 'srx))
	(rif (lookup 'rif)))
    (case srx
      (0 (putprop 'r nil 'idx))
      (1 (putprop 'r rif 'idx))
      (2 (putprop 'r 'ba 'idx))
      (4 (putprop 'r 'df 'idx))
      (10 (putprop 'r 'sf 'idx))
      (t (format t "ERROR: invalid srx ~A~%" srx)))))

(defun update-rd ()
  (if (get 'r 'idx)
      (set-input 'rd 'r)
      (set-input 'rd 0)))

(defun update-bc ()
  (case (lookup 'sbc)
    (0 (set-input 'bc 'bc-traps))
    (1 (set-input 'bc 1))
    (2 (set-input 'bc 2))
    (3 (set-input 'bc 'bc-12))
    ((4 5 6) (set-input 'bc 'bc-unused))
    (7 (set-input 'bc 'bc-consinc))
    (10 (set-input 'bc 177570))		; SR ADRS
    (11 (set-input 'bc 'bc-pwr-up))
    (12 (set-input 'bc 17))		; CC mask
    (13 (set-input 'bc 77))		; SOB mask
    (14 (set-input 'bc 'bc-sinclk))
    (15 (set-input 'bc '250))		; MM vector
    (16 (set-input 'bc 'mm-const))
    (17 (set-input 'bc 4))))            ; stack 4

(defun update-bmux ()
  (case (lookup 'sbm)
    (0 (set-input 'bmux 'b))
    (2 (set-input 'bmux 'b-hi))
    (5 (set-input 'bmux 'b-sxt))
    (10 (set-input 'bmux 'b-lo))
    (12 (set-input 'bmux 'b-swab))
    (17 (set-input 'bmux (get 'bc 'input)))
    (t (format t "ERROR: invalid SBM ~A~%" (lookup 'sbm)))))

(defun reg67p ()
  (let ((ri (get 'r 'idx)))
    (and (numberp ri)
	 (or (= ri 6) (= ri 7)))))

;; BCON12 CIN
;;     SALU0 * (R67 + ~BYTEOP)     + 11
;;     SALU1 * ~(R67 + ~BYTEOP)    - 06
;;           * ~R67 * BYTEOP
(defun update-cin ()
  (let ((alu (lookup 'alu))
	(dad (lookup 'dad))
	(bc (get 'bc 'input)))
;    (format t "updating CIN ~A ~A ~A~%" alu dad bc)
    (cond
      ;; forced carry
      ((= (logand dad 16) 10)
       (set-input 'cin 1))
      ;; autoincrement R[6+7]
      ((and (eq bc 'bc-12)
	    (logbitp 0 alu)
	    (reg67p))
       (set-input 'cin 1))
      ;; ALU function from IR
      ((= (logand dad 14) 14)
       (set-input 'cin 'c-ir))
      ;; The following is not stritly exclusive with the above if it is 0
      ;; but in practice we can assume it is
      ((and (eq bc 'bc-12)
	    (logbitp 0 alu)
	    (not (reg67p)))
       (set-input 'cin (list (get 'r 'idx)))
       (putprop 'cin 'c-autoinc 'op))
      ((and (eq bc 'bc-12)
	    (logbitp 1 alu)
	    (not (reg67p)))
       (set-input 'cin (list (get 'r 'idx)))
       (putprop 'cin 'c-autodec 'op))
      (t (set-input 'cin 0)))))

;; used: 0 (A), 03 (-1), 06 (A-B-1), 11 (A+B), 17 (A-1), 23 (0), 25 (~B), 32 (B), 33 (A&B), 36 (A|B)
(defun update-alu ()
  (set-input 'alu '(rd bmux))	;; maybe not necessary...
  (let ((dad (lookup 'dad))
	(alu (lookup 'alu)))
    (if (= (logand dad 14) 14)
	(putprop 'alu 'alu-ir 'op)
	(case alu
	  ;; arithmetic
	  (0 (set-input 'alu '(rd cin))
	     (putprop 'alu 'alu-a 'op))
	  (3 (set-input 'alu '(cin))
	     (putprop 'alu 'alu-minus-1 'op))
	  (6 (set-input 'alu '(rd bmux cin))
	     (putprop 'alu 'alu-a-minus-b-minus-1 'op))
	  (11 (set-input 'alu '(rd bmux cin))
	      (putprop 'alu 'alu-a-plus-b 'op))
	  (17 (set-input 'alu '(rd cin))
	      (putprop 'alu 'alu-a-minus-1 'op))
	  ;; logical
	  (23 (set-input 'alu '(fake))
	      (putprop 'alu 'alu-0 'op))
	  (25 (set-input 'alu '(bmux))
	      (putprop 'alu 'alu-not-b 'op))
	  (32 (set-input 'alu '(bmux))
	      (putprop 'alu 'alu-b 'op))
	  (33 (putprop 'alu 'alu-a-and-b 'op))
	  (36 (putprop 'alu 'alu-a-or-b 'op))
	  (t (format t "unk alu op ~A~%" alu)
	   (putprop 'alu 'alu-unk 'op))))))

(defun update-dmux ()
  (case (lookup 'sdm)
    (0 (set-input 'dmux 'rd))
    (1 (set-input 'dmux 'unibus-data))
    (2 (set-input 'dmux 'd))
    (3 (set-input 'dmux '(cout d))
       (putprop 'dmux 'shift 'op))))

(defun update-bamux ()
  (case (lookup 'sba)
    (0 (set-input 'bamux 'alu))
    (1 (set-input 'bamux 'rd))))

(defun setup-datapath ()
  (setq *dad* (lookup 'dad))      ;; TODO remove
  (update-r )
  (update-rd )
  (update-bc )
  (update-bmux )
  (update-cin )
  (update-alu )
  (update-dmux )
  (update-bamux )
  (putprop 'bus (lookup 'bus) 'clk)
  (putprop 'ir (nzerop (lookup 'cir)) 'clk)
  (putprop 'b (nzerop (lookup 'cb)) 'clk)
  (putprop 'd (nzerop (lookup 'cd)) 'clk)
  (putprop 'ba (nzerop (lookup 'cba)) 'clk)
  (case (lookup 'wr)
    (0 (putprop 'r nil 'clk))
    (1 (putprop 'r 'low 'clk))
    (2 (putprop 'r 'high 'clk))
    (3 (putprop 'r t 'clk))))

(defun emit-combiner (comb)
  ;(format t "testing ~A ~A~%" comb (and (symbolp comb) (symbol-plist comb)))
  (when (and comb
	     (symbolp comb)
	     (get comb 'input)
	     (dirtyp comb)
	     (not (get comb 'regp)))
    (let ((input (get comb 'input)))
      (and (atom input)
	   (emit-combiner input))
      (and (listp input)
	   (mapc #'emit-combiner input))
      (format t "	~A = ~A;~%" (xpr-to-c comb) (input-to-c comb))
      (putprop comb nil 'dirtyp))))
       
(defun process-clk (regs)
  (mark-all-dirty-from-inputs)
  (mark-all-regs-clean)
  ;; emit combinational assignments
  (dolist (r regs)
    (and (get r 'clk)
	 (emit-combiner (get r 'input))))
  ;; emit register assignments
  (dolist (r regs)
    (let ((clk (get r 'clk))
	  (dst (xpr-to-c r))
	  (src (input-to-c r)))
      (when clk
	(case clk
	  (low  (format t "	SETLOW(~A,~A);~%" dst src))
	  (high (format t "	SETHIGH(~A,~A);~%" dst src))
	  (t    (format t "	~A = ~A;~%" dst src)))
	(putprop r t 'dirtyp)))))

(defun ba-clk ()
  (when (get 'ba 'clk)
    (let ((ri (get 'r 'idx)))
      ;; CKOVF
      (if (or (/= (logand *dad* 16) 6)
	      (and (numberp ri) (/= ri 6)))
	  (format t "	CKOVF = 0;~%")
	  (format t "	CKOVF = (~A == 6) && !STALL;~%" (xpr-to-c ri)))
      ;; CKODA
      (if (logbitp 0 *dad*)
	  (format t "	CKODA = BYTE_INST;~%")
	  (format t "	CKODA = 0;~%")))))

(defun bus-clk ()
  (let ((bg (logbitp 0 (get 'bus 'clk)))
	(c (ash (get 'bus 'clk) -1)))
    (when bg
      (case c
	(0 (format t "	BUS_C = DATI;~%"))
	(1 (format t "	BUS_C = DATIP & DATIP_MASK;~%"))
	;; slightly ugly
	(2 (if (logbitp 0 *dad*)
	       (format t "	BUS_C = DATO | BYTE_INSTR;~%")
	       (format t "	BUS_C = DATO;~%")))
	;; simplified because DATIP_MASK never applies due to microinstruction flow
	(3 (format t "	BUS_C = DATOB;~%")))
      )))



(defun clk-p1 ()
  (format t "    // P1:~%")
  (process-clk '(ba b ir r))
  (ba-clk)
  (bus-clk))

(defun clk-p2 ()
  (format t "    // P2:~%")
  (process-clk '(ba d))
  (ba-clk)
  (bus-clk))

(defun clk-p3 ()
  (format t "    // P3:~%")
  (process-clk '(b ir r)))

;; PUPP = UPP;
;; switch(UPP){
;; case FET04:
;; 	UPP = FET05 | BUT;
;; 	BUT = BUT37;
;; 	break;
;; case FET05:
;; 	UPP = 100 | BUT;
;; 	BUT = 0;
;; 	break;
;; }

(defun process-uword (uword)
  (set-bindings uword)
  (setup-datapath)
  (mark-all-dirty)
  (format t "~%case ~A:	// ~A~%" (lookup 'state) (lookup 'adr))
  (format t "	UPP = ~A | BUT;~%" (xpr-to-c (lookup 'upf)))
  (format t "	BUT = BUT~A;~%" (lookup 'ubf))
  (let ((clk (lookup 'clk)))
    (case (ash clk -1)
      ((0 1) (clk-p1))
      (2 (clk-p2))
      (3 (clk-p2)
	 (clk-p3)))
    (and (logbitp 0 clk)
	 (format t "	CLKOFF;~%")))
  (format t "	break;~%"))

(with-open-file (*standard-output* "ucode_40_c.txt" :direction :output :if-exists :supersede)
  (mapc #'process-uword *words*)
  nil)

;(process-uword (find-word 'fet01))
;(process-uword (find-word 'fet03))
;(process-uword (find-word 'fet04))
;(process-uword (find-word 'fet05))
;(process-uword (find-word 'fet06))
;(process-uword (find-word 'dop00))
;(process-uword (find-word 'rsr04))
;(process-uword (find-word 'rsr06))
;(process-uword (find-word 'dop08))