Implement MAKE-GC-FINALIZED-OBJECT.

diff --git a/v7/src/runtime/gcfinal.scm b/v7/src/runtime/gcfinal.scm
index 458674fc85527f6deda64dc611311d7b72f86f2e..e5d2d084c982cc1c373b74525042a99c41c3a0f1 100644 (file)
--- a/v7/src/runtime/gcfinal.scm
+++ b/v7/src/runtime/gcfinal.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: gcfinal.scm,v 14.5 2003/02/14 18:28:32 cph Exp $
+$Id: gcfinal.scm,v 14.6 2003/06/08 04:07:08 cph Exp $
 
-Copyright (c) 2000, 2002 Massachusetts Institute of Technology
+Copyright 2000,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -79,7 +79,7 @@ USA.
                             (set-gc-finalizer-items! finalizer next))
                         (procedure (weak-cdr (car items))))
                       (loop (cdr items) items)))))))))
-
+\f
 (define (remove-all-from-gc-finalizer! finalizer)
   (guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!)
   (let ((procedure (gc-finalizer-procedure finalizer)))
@@ -93,7 +93,7 @@ USA.
                 (if (weak-pair/car? item)
                     (procedure (weak-cdr item)))
                 (loop)))))))))
-\f
+
 (define (search-gc-finalizer finalizer predicate)
   (guarantee-gc-finalizer finalizer 'SEARCH-GC-FINALIZER)
   (without-interrupts
@@ -118,6 +118,32 @@ USA.
                       objects)))
           (reverse! objects))))))
 
+(define (make-gc-finalized-object finalizer get-context context->object)
+  ;; A bunch of hair to permit microcode descriptors be opened with
+  ;; interrupts turned on, yet not leave a dangling descriptor around
+  ;; if the open is interrupted before the runtime system's data
+  ;; structures are updated.
+  (guarantee-gc-finalizer finalizer 'MAKE-GC-FINALIZED-OBJECT)
+  (let ((p (weak-cons #f #f)))
+    (dynamic-wind
+     (lambda () unspecific)
+     (lambda ()
+       (and (get-context p)
+           (let ((context (weak-cdr p)))
+             (let ((object (context->object context)))
+               (without-interrupts
+                (lambda ()
+                  (weak-set-cdr! p object)
+                  (set-gc-finalizer-items!
+                   finalizer
+                   (cons p (gc-finalizer-items finalizer)))))
+               object))))
+     (lambda ()
+       (if (and (not (weak-pair/car? p)) (weak-cdr p))
+          (begin
+            ((gc-finalizer-procedure finalizer) (weak-cdr p))
+            (weak-set-cdr! p #f)))))))
+\f
 (define gc-finalizers)
 
 (define (reset-gc-finalizers)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 2baccb80c723122a2f8d563fa94cbd60711633c9..29b5c0530806ac4d07d9a1d49618a0b15f79f62b 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.445 2003/04/17 02:52:12 cph Exp $
+$Id: runtime.pkg,v 14.446 2003/06/08 04:07:12 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1597,6 +1597,7 @@ USA.
          add-to-gc-finalizer!
          gc-finalizer-elements
          gc-finalizer?
+         make-gc-finalized-object
          make-gc-finalizer
          remove-all-from-gc-finalizer!
          remove-from-gc-finalizer!