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


;;;; Simulation stuff

;;; These things simulate the hw primops

(defvar *vma* 0)
(defvar *md*  0)
(defvar *screen-array* (zl:make-array (/ (apply #'*
					     (array-dimensions
					       (tv:sheet-screen-array tv:main-screen)))
				      16.)
				   :type 'zl:art-16b
				   :displaced-to (tv:sheet-screen-array tv:main-screen)))


;;; virtual memory interface simulation

(defmacro hw:write-vma-unboxed (addr)
  `(setq *vma* ,addr))

(defmacro hw:write-md-unboxed (data)
  `(setq *md* ,data))

(defmacro hw:read-md ()
  '*md*)

(defun hw:vma-start-write-unboxed (addr)
  (hw:write-vma-unboxed addr)
  (start-write))

(defun hw:md-start-write-unboxed (data)
  (hw:write-md-unboxed data)
  (start-write))

(defun hw:vma-start-read-vma-unboxed-md-unboxed (addr)
  (hw:write-vma-unboxed addr)
  (start-read))


(defun start-write ()
  (zl:aset (logand #xFFFF *md*) *screen-array* (ash *vma* 1))
  (zl:aset (ash *md* -16)       *screen-array* (1+ (ash *vma* 1))))

(defun start-read ()
  (setq *md* (logior (aref *screen-array* (ash *vma* 1))
		     (ash (aref *screen-array* (1+ (ash *vma* 1))) 16. ))))
  
  
;;; bitfield manipulation / word surgery

(defun hw:dpb (value byte-spec word)
  (let* ((mask1 (logxor (ash -1 (byte-position byte-spec))
			(ash -1 (+ (byte-size byte-spec)
				   (byte-position byte-spec)))))
	 (mask2 (logand #xffffffff (lognot mask1))))
    (logior (logand mask2 word)
	    (logand mask1 (ash value (byte-position byte-spec))))))    



(defun hw:ldb  (from byte-spec into)
  (let* ((mask1 (ash #xffffffff (byte-size byte-spec)))
	 (mask2 (logand #xffffffff (lognot mask1))))
    (logior (logand mask1 into)
	    (logand mask2 (ash from (- (byte-position byte-spec)))))))


(defun hw:selective-deposit (value byte-spec word)
  (let ((mask (ash (lognot (ash #xffffffff
				(byte-size byte-spec)))
		   (byte-position byte-spec))))
    (logior (logand value mask)
	    (logand word
		    (lognot mask)))))