;;; dump.scm

;;; (Use of this file may be hazardous to your garbage collector!!!)

;;;
;;; Object TAGS are in bits 31:28
;;;

(define TAG_PAIR		#x00)	; cdr offset = 0, car offset = 4
(define TAG_STREAM		#x01)	; pair underneath
(define TAG_ENV 		#x02)	; pair underneath
(define TAG_CLOSURE		#x03)	; pair underneath
(define TAG_VECTOR		#x04)	; size, byte_size, ref, ref, ...
(define TAG_NUMBER		#x05)	; constant or pointer to rawdata in 23:0
(define TAG_STRING		#x06)	; size, char, char, ...
(define TAG_PORT		#x07)	; subtagged, value stored in bits 23:0
(define TAG_SMALLCONST		#x08)	; small constants -- see below
(define TAG_SYMBOL		#x09)	; index into symbol list
(define TAG_EOF_OBJECT		#x0A)	; point ptr in 24:0, but don't reuse it
(define TAG_ENIGMA		#x0B)	; for "boxed" values; value in bits 23:0
(define TAG_STORAGE		#x0C)	; "scrap" memory -- unspecified format
; --- no tag $0D
; --- no tag $0E
(define TAG_RAWDATA		#x0F)	; raw data in heap; size in bits 23:0

(define TAG_IMPOSSIBLE		TAG_SMALLCONST) ; marks gc forwarding pointers
(define TAG_UNIT		TAG_SMALLCONST)
(define TAG_EMPTY_LIST		TAG_SMALLCONST)
(define TAG_EMPTY_STREAM	TAG_SMALLCONST)
(define TAG_CHARACTER		TAG_SMALLCONST) ; character in bits 7:0
(define TAG_BOOLEAN		TAG_SMALLCONST)
(define TAG_STACK_MARKER	TAG_SMALLCONST) ; don't store this anywhere!!!


;;;
;;; Subtags are in bits 27:24
;;;

(define SC_SUBTAG_IMPOSSIBLE	#x00)
(define SC_SUBTAG_UNIT		#x01)
(define SC_SUBTAG_EMPTY_LIST	#x02)
(define SC_SUBTAG_EMPTY_STREAM	#x03)
(define SC_SUBTAG_CHARACTER	#x04)
(define SC_SUBTAG_BOOLEAN	#x05)
(define SC_SUBTAG_STACK_MARKER	#x06)

(define CL_SUBTAG_UNSPECIFIED	#x00)
(define CL_SUBTAG_PRIMITIVE	#x01)
(define CL_SUBTAG_PROCEDURE	#x02)
(define CL_SUBTAG_COMPILED	#x03)
(define CL_SUBTAG_THUNK 	#x04)
(define CL_SUBTAG_PROMISE	#x05)
(define CL_SUBTAG_CONTINUATION	#x06)

(define NUM_SUBTAG_CONSTANT	#x00)	; signed value stored in bits 15:0
(define NUM_SUBTAG_FIXNUM	#x01)	; pointer to rawdata holding a longword
(define NUM_SUBTAG_RATNUM	#x02)	; not currently used
(define NUM_SUBTAG_BIGNUM	#x03)	;  "     "       "
(define NUM_SUBTAG_FLONUM	#x04)	;  "     "       "
(define NUM_SUBTAG_NUMBER_PAIR	#x05)	;  "     "       "


(define tag-name
  (vector
    'TAG_PAIR
    'TAG_STREAM
    'TAG_ENV
    'TAG_CLOSURE
    'TAG_VECTOR
    'TAG_NUMBER
    'TAG_STRING
    'TAG_PORT
    'TAG_SMALLCONST
    'TAG_SYMBOL
    'TAG_EOF_OBJECT
    'TAG_ENIGMA
    'TAG_STORAGE
    '*UNKNOWN-TAG*
    '*UNKNOWN-TAG*
    'TAG_RAWDATA))



(define closure? procedure?)

(define (call-with-tag&subtag&ref obj proc)
  (let ((rep (obj->rep obj)))
    (call-with-quotient&remainder (car rep) #x10
      (lambda (tag subtag)
	(proc tag subtag (cdr rep))))))

(define (dump-obj-rep obj)
  (call-with-tag&subtag&ref obj
    (lambda (tag subtag ref)
      (list tag (vector-ref tag-name tag) subtag ref))))


(define (error-if-not-closure obj)
  (if (not (closure? obj))
      (error "object not a closure" obj)))



(define (closure-params closure)
  (error-if-not-closure closure)
  (dump-obj-rep (!storage-ref closure 1)))



(define (compound-procedure-params proc)
  (if (compound-procedure? proc)
      (!storage-ref proc 1)
      (error "object not a compound procedure" proc)))

(define (compound-procedure-body proc)
  (if (compound-procedure? proc)
      (car (!storage-ref proc 0))
      (error "object not a compound procedure" proc)))

(define (compound-procedure-env proc)
  (if (compound-procedure? proc)
      (cadr (!storage-ref proc 0))
      (error "object not a compound procedure" proc)))



;-------------------------------------------------------------------------------
;
; CONTINUATION STRUCTURE
; ----------------------
;
; (#u body-code env-stuff . pspec)
;
;      pspec:1 (boxed)	(parameter specifier: exactly 1 argument)
;  body-code:boxed pointer to 68k code
;  env-stuff:(Scheme_stack proc_stack state_point . ???)
;
;	      env:environment in which continuation was created
;    Scheme_stack:VECTOR containing the Scheme stack during creation
;      proc_stack:STORAGE containing the processor stack during creation
;     state_point:the state point during creation
;
; All the Scheme registers are pushed onto the Scheme_stack before the
; vector is created.
;
;-------------------------------------------------------------------------------
;
; STATE POINT STRUCTURE
; ---------------------
;
; (parent_state_point entry_thunk exit_thunk boxed_interrupt_mask . ???)
;
; Note that state points have no special tags; they are just lists.
; It is not currently intended that they be first-class (or even expressible)
; in the system.
;
;-------------------------------------------------------------------------------

(define (dump-continuation cont)
  (if (continuation? cont)
      (list (dump-obj-rep (car (!storage-ref cont 0)))
	    (cadr (!storage-ref cont 0)))
      (error "object not a continuation" cont)))

(define (dump-continuation-proc-stack cont)
  (let ((cont-dump (dump-continuation cont)))
    (let ((proc-stack (cadr (cadr cont-dump))))
      (let ((proc-stack-rep (!storage-rep-ref proc-stack 0)))
	(let ((byte-size (+ (* #x1000000 (car proc-stack-rep)) (cdr proc-stack-rep))))
	  (let ((n-items (inexact->exact (/ byte-size 4))))
	    (define (dump-items i item-list)
	      (if (< i 1)
		  item-list
		  (dump-items (- i 1) (cons (!storage-rep-ref proc-stack i) item-list))))
	    (dump-items n-items '()) ))))))

(define (dump-continuation-Scheme-stack cont)
  (let ((cont-dump (dump-continuation cont)))
    (let ((Scheme-stack (car (cadr cont-dump))))
      Scheme-stack)))



;-------------------------------------------------------------------------------
;
; ENVIRONMENT STRUCTURE
; ---------------------
;      env
;	 \
;	  OO
;	 /  \
;	/    \		  To find a binding, search each frame in var-list from
; var-list  val-list	  frame0 for the desired symbol.  If found at frame F,
;			  binding B, then find its value in frame F, binding B
;			  of val-list.
; var-list
;   -or-
; val-list
;	\
;	 OO-----OO-- - - --OO-nil
;	 |	|	   |
;	 |	|	   |
;      frame0 frame1	 frameJ-1
;
;  frameI
;     \
;      OO-----OO-- - - --OO-nil
;      |      | 	 |
;      |      | 	 |
;    var0   var1       varK-1
;    -or-   -or-       -or-
;    val0   val1       valK-1
;
;-------------------------------------------------------------------------------

(define (dump-env-var-frame-list env)
  (if (environment? env)
      (!storage-ref env 1)
      (error "object not an environment" env)))

(define (dump-env-val-frame-list env)
  (if (environment? env)
      (!storage-ref env 0)
      (error "object not an environment" env)))

(define (dump-env env)
  (cons (dump-env-var-frame-list env)
	(dump-env-val-frame-list env)))

(define (dump-env-bindings env)
  (map (lambda (var-list val-list)
	 (map (lambda (var val)
		(cons var val))
	      var-list
	      val-list))
       (dump-env-var-frame-list env)
       (dump-env-val-frame-list env)))



;;; EOF dump.scm