;; "gsi.scm"  -- Ken's variant of Marc's GSI
;;		 Adds finalization service and unscanned vectors.

(##declare
  (extended-bindings)
  (not safe)
  (not autotouch)
  (block)
  (fixnum))

;------------------------------------------------------------------------------
; FILE		"final.scm"
; IMPLEMENTS	Finalization service.
; AUTHOR	Ken Dickey
; DATE 		1991 March 21
; LAST UPDATED	1991 November 21

; PURPOSE: Clean up files, dumb malloc'ed storage, etc.
;
; USAGE:  (register-for-finalization <object> <thunk>)
;
; SEMANTICS: After each storage reclamation cycle (a.k.a. GC),
; if the <object> has been collected, the <thunk> is invoked.
;
; INVARIANT: The <thunk> must not cons (i.e. not allocate storage).

; IMPLEMENTATION: Uses weak-pairs.  When the <object> in the car of
; the weak-cons goes to #f, the <thunk> in the cdr is executed.
; [This code is somewhat harder to follow because it takes great
; care not to cons.  Assignment is useful after all! 8^].

(define  REGISTER-FOR-FINALIZATION 

  (let ( (CHAIN (cons #f '() ))   ;; INVARIANT: chain is a CONS
	 (POINT (cons #f  #f ))	  ;; used in post-gc-deamon, below.
       )
   
    (set! ##gc-finalize
	  (lambda ()
	    ;; (car point) points to previous
	    ;; (cdr point) points to current
	    (set-car! point chain)
	    (set-cdr! point (cdr chain))

	    (let loop ()
	      (cond 
	       ((null? (cdr point)) #f)   ;; done

	       ((not (##weak-car (cadr point)))    ;; (false? (car weak-pair))
	        (set-cdr! (car point) (cddr point))    ;; splice it out
		( (##weak-cdr (cadr point)) )	       ;; (finalize!)
		;; next!
	        (set-cdr! point (cddr point))
		(loop)
	       )

	       (else			;; skip it
		;; next!
		(set-car! point (cdr  point))
		(set-cdr! point (cddr point))
		(loop)))
	     ))
    )

    (lambda (<object> <thunk>)
      (set-cdr! chain (cons (##weak-cons <object> <thunk>) (cdr chain)))
      'registered)
) )

;------------------------------------------------------------------------------
;;FILE:		"unscanned.scm"
;;
;;IMPLEMENTS:	Test implementation of unscanned vectors for the
;;		Gambit1.51 runtime system -- in order to hold binary
;;		objects (such as 'C' pointers) which should not be 
;;		scanned by the collector.
;;
;;AUTHOR:	Kenneth Dickey
;;DATE:		1991 September 24
;;LAST UPDATED:
;;NOTES:        


(define UNSCANNED-VECTOR-TAG 19)

(define (MAKE-UNSCANNED-VECTOR vsize)
  (let ( (v (##make-vector vsize 0)) )
     (##subtype-set! v unscanned-vector-tag)
     v
) )

(define (UNSCANNED-VECTOR? v)
  (and (##subtyped? v) (= (##subtype v) unscanned-vector-tag))
)

(define (UNSCANNED-VECTOR-SET! v index val)
  (if (unscanned-vector? v)
      (##vector-set! v index val)
      (##error "Set!: Bad unsigned vector" v)
) )

(define (UNSCANNED-VECTOR-REF v index)
  (if (unscanned-vector? v)
      (##vector-ref v index)
      (##error "Ref: Bad unsigned vector" v)
) )

(define (UNSCANNED-VECTOR-LENGTH v)
  (if (unscanned-vector? v)
      (/ (##string-length v) 4) ;; ##vector-length does not work here...
      (##error "Length: Bad unsigned vector" v)
) )


;------------------------------------------------------------------------------
;------------------------------------------------------------------------------

(let ((v ##argv))
  (let ((n (##vector-length v)))
    (if (##fixnum.= n 1)

      (begin
        (##display "Gambit (v1.8)" ##stdout #f)
        (##newline ##stdout)
        (let ((init (##open-input-file "SCM:init.scm")))
          (if init (begin (##close-port init) (load "SCM:init.scm"))
            (let ((init (##open-input-file "init.scm")))
              (if init (begin (##close-port init) (load "init.scm"))))))
        (##repl))

      (let loop1 ((i 1))
        (if (##fixnum.< i n)
          (let ((port (##open-input-string (##vector-ref v i))))
            (let loop2 ()
              (let ((expr (##read port)))
                (if (##not (##eof-object? expr))
                  (let ((val (##eval-global expr)))
                    (##write val ##stdout #t)
                    (##newline ##stdout)
                    (loop2)))))
            (##close-port port)
            (loop1 (##fixnum.+ i 1))))))))

;------------------------------------------------------------------------------