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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; hooks for the debugger
;;; read and modify registers in a frame

(defun control-pdl-depth (control-pdl)
  "Index of topmost frame of control pdl"
  (floor (- (control-pdl-pointer control-pdl) control-pdl-base)
	 control-pdl-frame-size))

(defun control-pdl-frame-info (control-pdl frame-number)
;  (declare (values type rpc rdest global-frame))
  (let ((frame-index (+ control-pdl-base (* control-pdl-frame-size frame-number)))
	word0 word1)
    (when (>= frame-index (control-pdl-pointer control-pdl))
      (li:error "frame not in control pdl"))
    (setq word0 (array:%vm-read32 control-pdl frame-index))
    (setq word1 (array:%vm-read32 control-pdl (1+ frame-index)))
    (values (hw:ldb word0 %%cpdl0-type-code 0)		;type
	    word1					;RPC
	    (hw:ldb word0 %%cpdl0-rdest	0)		;RDEST
	    (hw:ldb word0 %%cpdl0-global-frame 0))))	;global frame

(defun control-pdl-frame-examine-register (control-pdl frame-number register-number)
  (let ((frame-index (+ control-pdl-base (* control-pdl-frame-size frame-number)))
	box-bits datum)
    (when (>= frame-index (control-pdl-pointer control-pdl))
      (li:error "frame not in control pdl"))
    (setq box-bits (hw:ldb (array:%vm-read32 control-pdl frame-index) %%cpdl0-box-bits 0))
    (setq datum (array:%vm-read32 control-pdl (+ control-pdl-frame-offset-to-registers
						 register-number frame-index)))
    (if (hw::32logbitp register-number box-bits)
	(hw:dpb-boxed datum (byte 32 32) (hw:unboxed-constant 0))	;make boxed
      datum)))								;unboxed

(defun control-pdl-frame-modify-register (control-pdl frame-number register-number new-value boxed-p)
  (let ((frame-index (+ control-pdl-base (* control-pdl-frame-size frame-number)))
	word0)
    (when (>= frame-index (control-pdl-pointer control-pdl))
      (li:error "frame not in control pdl"))
    (setq word0 (array:%vm-read32 control-pdl frame-index))
    (flet ((change-datum ()
	     (array:%vm-write32 control-pdl (+ control-pdl-frame-offset-to-registers
					 register-number frame-index) new-value))
	   (change-box-bit ()
	     (array:%vm-write32 control-pdl frame-index
			  (hw:dpb (hw:dpb (if boxed-p 1 0)
					  (byte 1 register-number)
					  (hw:ldb word0 %%cpdl0-box-bits 0))
				  %%cpdl0-box-bits
				  word0))))
      (if boxed-p				;try and do this safely
	  (progn (change-datum)
		 (change-box-bit))
	(progn (change-box-bit)
	       (change-datum))) )))