; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file transport.scm.

;;;; Transporters to and from simulated heap.

(define (initialize-transporter)
  (set! *symbol-table*	     (s48:make-vector table-size))
  (s48:vector-fill! *symbol-table* s48:null)
  (set! *system-environment* (s48:make-vector table-size))
  (s48:vector-fill! *system-environment* s48:null))

; Scheme value -> simulated value
;  This is a dangerous thing to call.  It's essential that there be
;  enough space for this routine to allocate whatever storage it
;  needs, without any need for GC, since there isn't any
;  opportunity to do one.

(define (enter obj)
  (cond ((integer? obj) (enter-fixnum obj))
        ((char? obj) (enter-char obj))
        ;; The relative ordering of the next two clauses is
	;; important when we boot the system from a scheme that
	;; doesn't distinguish #f from ().
        ((eq? obj '()) s48:null)
        ((eq? obj #f) s48:f)
        ((eq? obj #t) s48:t)
        ((pair? obj)
         (s48:cons (enter (car obj)) (enter (cdr obj))))
        ((symbol? obj)
	 (s48:intern (enter (symbol->string obj)) *symbol-table*))
        ((code-vector? obj)  ;should precede string case
	 (let ((v (s48:make-code-vector (code-vector-length obj))))
	   (do ((i 0 (+ i 1)))
	       ((>= i (code-vector-length obj)) v)
	     (s48:code-vector-set! v i (code-vector-ref obj i)))))
        ((string? obj)
	 (let ((v (s48:make-string (string-length obj))))
	   (do ((i 0 (+ i 1)))
	       ((>= i (string-length obj)) v)
	     (s48:string-set! v i (string-ref obj i)))))
        ((cell? obj)
         (s48:lookup *system-environment* (enter (cell-name obj))))
        ;; Vector case must be last, for simulation
	((vector? obj)
	 (let ((v (s48:make-vector (vector-length obj))))
	   (do ((i 0 (+ i 1)))
	       ((>= i (vector-length obj)) v)
	     (s48:vector-set! v i (enter (vector-ref obj i))))))
        (else
         (error "unenterable object" obj))))

; Simulated value -> scheme value

(define (extract obj)
  (sub-extract obj '()))

(define (sub-extract obj a)
  (if (memv obj a)   ; a = ancestors
      (begin (newline)
	     (display "Cycle encountered: ")
	     (write a)
	     '<cycle>)
      (let ((a (cons obj a)))
	(cond ((s48:fixnum? obj) (extract-fixnum obj))
	      ((s48:char? obj) (extract-char obj))
	      ((s48:eq? obj s48:null) '())
	      ((s48:eq? obj s48:f) #f)
	      ((s48:eq? obj s48:t) #t)
	      ((s48:eq? obj s48:unspecified) '<unspecified>)
	      ((s48:pair? obj)
	       (cons (sub-extract (s48:car obj) a) (sub-extract (s48:cdr obj) a)))
	      ((s48:vector? obj)
	       (let ((z (s48:vector-length obj)))
		 (let ((v (make-vector z)))
		   (do ((i 0 (+ i 1)))
		       ((>= i z) v)
		     (vector-set! v i (sub-extract (s48:vector-ref obj i) a))))))
	      ((s48:symbol? obj)
	       (string->symbol (sub-extract (s48:symbol->string obj) a)))
	      ((s48:cell? obj)
	       (lookup system-environment (sub-extract (s48:cell-name obj) a)))
	      ((s48:closure? obj)
	       (make-closure (sub-extract (s48:closure-template obj) a)
			     (sub-extract (s48:closure-env obj) a)))
	      ((s48:string? obj)
	       (extract-string obj))
	      ((s48:code-vector? obj)
	       (let ((z (s48:code-vector-length obj)))
		 (let ((v (make-code-vector z)))
		   (do ((i 0 (+ i 1)))
		       ((>= i z) v)
		     (code-vector-set! v i (s48:code-vector-ref obj i))))))
	      (else `(<random> ,obj))))))