(##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) ;; you should probably not use this!
  (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 "S:init.scm")))
          (if init (begin (##close-port init) (load "S: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))))))))

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