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


(defun read-frame (frame-number)
  (read-frame-as-bignums frame-number)
  (let ((boxbits gr:*return-16*)
	(register-contents #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
    (dotimes (i 16)
      (setf (svref register-contents i)
	    (cons (hw:32logbitp i boxbits)
		  (unboxed-32-to-bignum (contents-of-return-value-register i)))))
    register-contents))


(defun contents-of-return-value-register (n)
  (dispatch (byte 5. 0) n
    (0 gr:*return-0*)   (1 gr:*return-1*)   (2 gr:*return-2*)   (3 gr:*return-3*)
    (4 gr:*return-4*)   (5 gr:*return-5*)   (6 gr:*return-6*)   (7 gr:*return-7*)
    (8 gr:*return-8*)   (9 gr:*return-9*)   (10 gr:*return-10*) (11 gr:*return-11*)
    (12 gr:*return-12*) (13 gr:*return-13*) (14 gr:*return-14*) (15 gr:*return-15*)
    (16 gr:*return-16*) (17 gr:*return-17*) (18 gr:*return-18*) (19 gr:*return-19*)
    (20 gr:*return-20*) (21 gr:*return-21*) (22 gr:*return-22*) (23 gr:*return-23*)
    (24 gr:*return-24*) (25 gr:*return-25*) (26 gr:*return-26*) (27 gr:*return-27*)
    (28 gr:*return-28*) (29 gr:*return-29*)
    (t (li:error "There are only thirty return-value global registers!"))))
	  

(defun read-frame-as-bignums (frame-number)
  (hw:nop)
  (hw:nop)
  (trap:without-traps
    #'(lambda ()
	(hw:nop)
	(hw:nop)
	(let ((oar (hw:read-open-active-return))
	      (boxbits 0))
	  (hw:write-open-active-return (hw:dpb frame-number (byte 8. 16.) oar))
	  (hw:nop)
	  (hw:nop)
	  (hw:nop)
	  (hw:nop)
	  (hw:nop)
	  (hw:nop)
	  (setq gr:*return-0* (hw:dpb-unboxed (hw:o0) (byte 32. 0.) 0.))
	  (setq gr:*return-1* (hw:dpb-unboxed (hw:o1) (byte 32. 0.) 0.))
	  (setq gr:*return-2* (hw:dpb-unboxed (hw:o2) (byte 32. 0.) 0.))
	  (setq gr:*return-3* (hw:dpb-unboxed (hw:o3) (byte 32. 0.) 0.))
	  (setq gr:*return-4* (hw:dpb-unboxed (hw:o4) (byte 32. 0.) 0.))
	  (setq gr:*return-5* (hw:dpb-unboxed (hw:o5) (byte 32. 0.) 0.))
	  (setq gr:*return-6* (hw:dpb-unboxed (hw:o6) (byte 32. 0.) 0.))
	  (setq gr:*return-7* (hw:dpb-unboxed (hw:o7) (byte 32. 0.) 0.))
	  (setq gr:*return-8* (hw:dpb-unboxed (hw:o8) (byte 32. 0.) 0.))
	  (setq gr:*return-9* (hw:dpb-unboxed (hw:o9) (byte 32. 0.) 0.))
	  (setq gr:*return-10* (hw:dpb-unboxed (hw:o10) (byte 32. 0.) 0.))
	  (setq gr:*return-11* (hw:dpb-unboxed (hw:o11) (byte 32. 0.) 0.))
	  (setq gr:*return-12* (hw:dpb-unboxed (hw:o12) (byte 32. 0.) 0.))
	  (setq gr:*return-13* (hw:dpb-unboxed (hw:o13) (byte 32. 0.) 0.))
	  (setq gr:*return-14* (hw:dpb-unboxed (hw:o14) (byte 32. 0.) 0.))
	  (setq gr:*return-15* (hw:dpb-unboxed (hw:o15) (byte 32. 0.) 0.))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o15)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o14)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o13)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o12)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o11)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o10)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o9)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o8)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o7)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o6)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o5)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o4)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o3)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o2)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o1)))
	  (setq boxbits (hw:accumulate-box-bits boxbits (hw:o0)))
	  (setq gr:*return-16* boxbits)
	  (hw:write-open-active-return oar)
	  (hw:nop)
	  (hw:nop)
	  (hw:nop)
	  (hw:nop)
	  (hw:nop)
	  (hw:nop))))
  NIL)

(defun unboxed-32-to-bignum (n)
  (if (or (zerop (hw:ldb n (byte 9. 23.) 0))
	  (= (hw:ldb n (byte 9. 23.) 0) #b111111111))
      (hw:ldb n vinc:%%fixnum-field 0)
      (let ((ptr (cons:allocate-structure
		   1 1 vinc::$$dtp-bignum
		   (cons:make-header vinc::$$dtp-unboxed-header 1))))
	(array:%vm-write32 ptr 1 n)
	ptr)))