diff options
Diffstat (limited to 'libguile/gc.c')
-rw-r--r-- | libguile/gc.c | 88 |
1 files changed, 88 insertions, 0 deletions
diff --git a/libguile/gc.c b/libguile/gc.c index eba10038c..2223c004a 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -678,8 +678,96 @@ scm_gc_unregister_roots (SCM *b, unsigned long n) int scm_i_terminating; +/* Finalizers. */ +static void +finalizer_trampoline (GC_PTR ptr, GC_PTR data) +{ + register SCM obj, finalizers; + + obj = PTR2SCM (ptr); + for (finalizers = PTR2SCM (data); + scm_is_pair (finalizers); + finalizers = SCM_CDR (finalizers)) + { + SCM f = SCM_CAR (finalizers); + + scm_call_2 (SCM_CAR (f), obj, SCM_CDR (f)); + } +} + + +/* Register FINALIZER as a finalization procedure for OBJ. FINALIZER will be + invoked when storage for OBJ is to be reclaimed and will be passed OBJ and + DATA. If ORDERED is non-zero, finalization will be "ordered" (see the + Boehm-GC doc for details). The function returns the data previously + registered for OBJ and FINALIZER, or `#f' if FINALIZER had not been + registered for OBJ before. + + Note that finalizers in general are known to be problematic. As such, + this function should only be used internally, and only to implement + functionalities that could not be implemented otherwise (e.g., guardians, + SMOB's free procedures). */ +SCM +scm_gc_register_finalizer (SCM obj, SCM (*finalizer) (SCM, SCM), + SCM data, int ordered) +{ + SCM prev_data = SCM_BOOL_F; + SCM finalization_data, finalization_subr; + GC_finalization_proc old_finalizer; + GC_PTR old_finalization_data; + + finalization_subr = scm_c_make_gsubr ("%%finalizer", 2, 0, 0, + finalizer); + finalization_data = scm_cons (scm_cons (finalization_subr, data), + SCM_EOL); + if (ordered) + GC_REGISTER_FINALIZER (SCM2PTR (obj), finalizer_trampoline, + SCM2PTR (finalization_data), + &old_finalizer, &old_finalization_data); + else + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalizer_trampoline, + SCM2PTR (finalization_data), + &old_finalizer, &old_finalization_data); + + if ((old_finalizer != NULL) && (old_finalizer != finalizer_trampoline)) + /* Inconsistent use of the mechanism. */ + abort (); + + if (old_finalization_data != NULL) + { + SCM f, prev, old_finalizer_list = PTR2SCM (old_finalization_data); + + if (!scm_is_pair (old_finalizer_list)) + abort (); + + /* Look for FINALIZER among the previously-installed finalizers. */ + for (f = old_finalizer_list, prev = SCM_BOOL_F; + scm_is_pair (f); + prev = f, f = SCM_CDR (f)) + { + if (SCM_SUBRF (SCM_CAR (f)) == finalizer) + break; + } + + if (scm_is_pair (f)) + { + prev_data = SCM_CDAR (f); + if (prev != SCM_BOOL_F) + SCM_SETCDR (prev, SCM_CDR (f)); + else + old_finalizer_list = SCM_CDR (old_finalizer_list); + } + + /* Concatenate the new finalizer list with the old one. */ + SCM_SETCDR (finalization_data, old_finalizer_list); + } + return prev_data; +} + + + /* MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC. */ |