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

; dest, s1, s2 could be:
;   (open 4)
;   (active 2)
;   (return 0)
;   (global 555)

; (alu dest <- s1 aluop s2)
; (jump condition target)
; (jump-xct-next condition target)

(defun parse-reg-adr (reg-adr &aux (limit *registers-per-frame*) base-code offset immediate)
  (declare (values base offset immediate))
  (setq offset (cadr reg-adr))
  (when (< offset 0) (ferror nil "bad offset"))
  (ecase (car reg-adr)
    (open
     (setq base-code %i-base-open))
    (active
     (setq base-code %i-base-active))
    (return
     (setq base-code %i-base-return))
    (global
     (setq base-code %i-base-global)
     (setq limit (* *registers-per-frame* *total-frames*))
     (setq immediate (floor offset *registers-per-frame*))
     (setq offset (remainder offset *registers-per-frame*))))
  (when (>= offset limit)
    (ferror nil "bad reg adr"))
  (values base-code offset immediate))
     

(defstruct (alu-inst (:type :list))
  flag
  dest
  arrow
  s1
  aluop
  s2)

(defun assemble-instruction (sym-inst &aux (val 0))
  (ecase (car sym-inst)
    (alu
     (let (base-code offset immediate old-immediate)
       ;;dest
       (multiple-value (base-code offset old-immediate)
	 (parse-reg-adr (alu-inst-dest sym-inst)))
       (setq val (dpb base-code %%i-dest-base val))
       (setq val (dpb offset %%i-dest-offset val))
       
       ;;s1
       (multiple-value (base-code offset immediate)
	 (parse-reg-adr (alu-inst-s1 sym-inst)))
       (setq val (dpb base-code %%i-src-1-base val))
       (setq val (dpb offset %%i-src-1-offset val))
       (when (and immediate old-immediate
		  (not (= immediate old-immediate)))
	 (ferror nil "inconsistant global bases"))

       ;;s2
       (multiple-value (base-code offset immediate)
	 (parse-reg-adr (alu-inst-s2 sym-inst)))
       (setq val (dpb base-code %%i-src-2-base val))
       (setq val (dpb offset %%i-src-2-offset val))
       (when (and immediate old-immediate
		  (not (= immediate old-immediate)))
	 (ferror nil "inconsistant global bases"))

       (ecase (alu-inst-aluop sym-inst)
	 (setz (setq val (dpb %i-aluf-setz %%i-aluf val)))
	 (add (setq val (dpb %i-aluf-add %%i-aluf val)))
	 )
       ))
    )
  val)