;; PDP-4 emulator

(defvar mem (make-vector 4096 0))

(defstruct pdp4
  (ac 0)
  (l 0)
  (mb 0)
  (ma 0)
  (ir 0)
  (pc 0)
  (sw 0)
  (run nil))

(defun pdp4-word (word)
  (logand word #o777777))

(defun pdp4-addr (word)
  (logand word #o0017777))

(defun pdp4-opcode (word)
  (logand word #o740000))

(defun pdp4-irb (c mask)
  (/= (logand (pdp4-ir c) mask) 0))

(defun pdp4-indirect (c)
  (/= (logand (pdp4-ir c) #o020000) 0))

(defun pdp4-read (c)
  (setf (pdp4-mb c) (pdp4-word (aref mem (pdp4-ma c)))))

(defun pdp4-write (c)
  (setf (aref mem (pdp4-ma c)) (pdp4-word (pdp4-mb c))))

(defun pdp4-inst (c)
  (setf (pdp4-ma c) (pdp4-pc c))
  (setf (pdp4-pc c) (pdp4-addr (+ (pdp4-pc c) 1)))
  (pdp4-read c)
  (setf (pdp4-ir c) (pdp4-mb c)))

(defun pdp4-address (c)
  (setf (pdp4-ma c) (pdp4-addr (pdp4-ir c)))
  (and (pdp4-indirect c)
       (setf (pdp4-ma c) (pdp4-addr (pdp4-read c)))))

(defun pdp4-ral (c)
  (let ((ac (lsh (pdp4-ac c) 1)))
    (setf ac (logior ac (pdp4-l c)))
    (setf (pdp4-l c) (logand (lsh ac -18) 1))
    (setf (pdp4-ac c) (pdp4-word ac))))

(defun pdp4-rar (c)
  (let ((ac (lsh (pdp4-ac c) -1)))
    (setf ac (logior ac (lsh (pdp4-l c) 17)))
    (setf (pdp4-l c) (logand (pdp4-ac c) 1))
    (setf (pdp4-ac c) (pdp4-word ac))))

(defun pdp4-execute (c)
  (let ((op (pdp4-opcode (pdp4-ir c))))
    (cond ((= op #o000000)
	   ;; cal
	   (setf (pdp4-ma c) #o20)
	   (and (pdp4-indirect c)
		(setf (pdp4-ma c) (pdp4-addr (pdp4-read c))))
	   (setf (pdp4-mb c) (pdp4-pc c))
	   (and (/= (pdp4-l c) 0)
	        (setf (pdp4-mb c) (logior (pdp4-mb c) #o400000)))
	   (pdp4-write c)
	   (setf (pdp4-pc c) (pdp4-addr (+ (pdp4-ma c) 1))))
	  ((= op #o040000)
	   ;; dac
	   (pdp4-address c)
	   (setf (pdp4-mb c) (pdp4-ac c))
	   (pdp4-write c))
	  ((= op #o100000)
	   ;; jms
	   (pdp4-address c)
	   (setf (pdp4-mb c) (pdp4-pc c))
	   (and (/= (pdp4-l c) 0)
	        (setf (pdp4-mb c) (logior (pdp4-mb c) #o400000)))
	   (pdp4-write c)
	   (setf (pdp4-pc c) (pdp4-addr (+ (pdp4-ma c) 1))))
          ((= op #o140000)
	   ;; dzm
	   (pdp4-address c)
	   (setf (pdp4-mb c) 0)
	   (pdp4-write c))
          ((= op #o200000)
	   ;; lac
	   (pdp4-address c)
	   (pdp4-read c)
	   (setf (pdp4-ac c) (pdp4-mb c)))
          ((= op #o240000)
	   ;; xor
	   (pdp4-address c)
	   (pdp4-read c)
	   (setf (pdp4-ac c) (logxor (pdp4-ac c) (pdp4-mb c))))
	  ((= op #o300000)
	   ;; add
	   (pdp4-address c)
	   (pdp4-read c)
	   (let ((a (+ (pdp4-ac c) (pdp4-mb c))))
	     (and (/= (logand a #o1000000) 0)
	          (setf a (+ a 1)))
	     (and (= (logand (logxor (pdp4-ac c) (pdp4-mb c)) #o400000) 0)
		  (/= (logand (logxor (pdp4-ac c) a) #o400000) 0)
	          (setf (pdp4-l c) 1))
	     (setf (pdp4-ac c) (pdp4-word a))))
	  ((= op #o340000)
	   ;; tad
	   (pdp4-address c)
	   (pdp4-read c)
	   (let ((a (+ (pdp4-ac c) (pdp4-mb c))))
	     (setf (pdp4-ac c) (pdp4-word a))
	     (and (/= (logand a #o1000000) 0)
	          (setf (pdp4-l c) 1))))
	  ((= op #o400000)
	   ;; xct
	   (pdp4-address c)
	   (pdp4-read c)
	   (setf (pdp4-ir c) (pdp4-mb c))
	   (pdp4-execute c))
	  ((= op #o440000)
	   ;; isz
	   (pdp4-address c)
	   (pdp4-read c)
	   (setf (pdp4-mb c) (pdp4-word (+ (pdp4-mb c) 1)))
	   (pdp4-write c)
	   (and (= (pdp4-mb c) 0)
	        (setf (pdp4-pc c) (+ (pdp4-pc c) 1))))
          ((= op #o500000)
	   ;; and
	   (pdp4-address c)
	   (pdp4-read c)
	   (setf (pdp4-ac c) (logand (pdp4-ac c) (pdp4-mb c))))
	  ((= op #o540000)
	   ;; sad
	   (pdp4-address c)
	   (pdp4-read c)
	   (and (/= (pdp4-ac c) (pdp4-mb c))
	        (setf (pdp4-pc c) (+ (pdp4-pc c) 1))))
          ((= op #o600000)
	   ;; jmp
	   (pdp4-address c)
	   (setf (pdp4-pc c) (pdp4-ma c)))
	  ((= op #o740000)
	   (if (pdp4-irb c #o020000)
	       ;; law
	       (setf (pdp4-ac c) (pdp4-ir c))
	       ;; opr
	       (let ((skip nil))
		 ;; cla
		 (and (pdp4-irb c #o010000)
		      (setf (pdp4-ac c) 0))
		 ;; cll
		 (and (pdp4-irb c #o004000)
		      (setf (pdp4-l c) 0))
		 ;; snl
		 (and (pdp4-irb c #o000400)
		      (/= (pdp4-l c) 0)
		      (setf skip t))
		 ;; sza
		 (and (pdp4-irb c #o000200)
		      (= (pdp4-ac c) 0)
		      (setf skip t))
		 ;; sma
		 (and (pdp4-irb c #o000100)
		      (/= (logand (pdp4-ac c) #o400000) 0)
		      (setf skip t))
		 ;; reverse skip condition
		 (and (pdp4-irb c #o001000)
		      (setf skip (not skip)))
		 ;; hlt
		 (and (pdp4-irb c #o000040)
		      (setf hlt t))
		 ;; rar
		 (and (pdp4-irb c #o000020)
		      (pdp4-rar c)
		      (pdp4-irb c #o002000)
		      (pdp4-rar c))
		 ;; ral
		 (and (pdp4-irb c #o000010)
		      (pdp4-ral c)
		      (pdp4-irb c #o002000)
		      (pdp4-ral c))
		 ;; oas
		 (and (pdp4-irb c #o000004)
		      (setf (pdp4-ac c) (logior (pdp4-ac c) (pdp4-sw c))))
		 ;; cml
		 (and (pdp4-irb c #o000002)
		      (setf (pdp4-l c) (logxor (pdp4-l c) 1)))
		 ;; cma
		 (and (pdp4-irb c #o000001)
		      (setf (pdp4-ac c) (logxor (pdp4-l ac) #o777777)))
		 (and skip (setf (pdp4-pc c) (+ (pdp4-pc c) 1))))))
	  (t "error"))))

(setf (aref mem #o200) #o200400)
(setf (aref mem #o201) #o040401)
(setf (aref mem #o202) #o140401)
(setf (aref mem #o203) #o240401)
(setf (aref mem #o204) #o500401)
(setf (aref mem #o205) #o600600)
(setf (aref mem #o206) #o540400)
(setf (aref mem #o207) #o100400)
(setf (aref mem #o210) #o440402)
(setf (aref mem #o211) #o400200)
(setf (aref mem #o212) #o340403)
(setf (aref mem #o213) #o300403)
(setf (aref mem #o214) #o001234)

(setf (aref mem #o400) 123456)
(setf (aref mem #o401) #o770077)
(setf (aref mem #o402) #o777777)
(setf (aref mem #o403) #o377777)
(defvar pdp4 (make-pdp4))
(setf (pdp4-ac pdp4) #o123456)
(setf (pdp4-ac pdp4) 123456)
(setf (pdp4-ac pdp4) 1)
(setf (pdp4-l pdp4) 0)

(setf (pdp4-pc pdp4) #o214)
(pdp4-inst pdp4)
(pdp4-execute pdp4)
pdp4
(aref mem #o20)
(aref mem #o400)
(aref mem #o401)
(aref mem #o402)
(aref mem #o201)