diff options
author | Andy Wingo <wingo@pobox.com> | 2025-05-02 16:21:17 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2025-05-02 16:26:17 +0200 |
commit | cf25a94745fc733af38db65fa62584ebba92bf93 (patch) | |
tree | 14c2f0a8000abddad1191afbc68bd0dab6064294 | |
parent | 532df66e0734a205d1e65b149bde7e1111c4000b (diff) | |
download | guile-cf25a94745fc733af38db65fa62584ebba92bf93.tar.gz |
Add tc7 for finalizer objects
Whippet will need this.
* libguile/scm.h (scm_tc7_finalizer): Reserve.
* libguile/evalext.c (scm_self_evaluating_p): Add finalizer case.
* libguile/print.c (iprin1):
* libguile/finalizers.h:
* libguile/finalizers.c (scm_i_print_finalizer): Arrange to print
finalizers.
* module/oop/goops.scm (<finalizer>):
* libguile/goops.c (class_finalizer, scm_class_of)
(scm_sys_goops_early_init): Wire up support for <finalizer>.
* module/system/base/types/internal.scm (heap-tags): Add finalizers.
* module/system/vm/assembler.scm (system): Add emit-finalizer?.
-rw-r--r-- | libguile/evalext.c | 1 | ||||
-rw-r--r-- | libguile/finalizers.c | 10 | ||||
-rw-r--r-- | libguile/finalizers.h | 2 | ||||
-rw-r--r-- | libguile/goops.c | 4 | ||||
-rw-r--r-- | libguile/print.c | 4 | ||||
-rw-r--r-- | libguile/scm.h | 2 | ||||
-rw-r--r-- | module/oop/goops.scm | 6 | ||||
-rw-r--r-- | module/system/base/types/internal.scm | 2 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 1 |
9 files changed, 28 insertions, 4 deletions
diff --git a/libguile/evalext.c b/libguile/evalext.c index 853b20333..f2486d7da 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -95,6 +95,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_bytevector: case scm_tc7_array: case scm_tc7_bitvector: + case scm_tc7_finalizer: case scm_tc7_thread: case scm_tcs_struct: return SCM_BOOL_T; diff --git a/libguile/finalizers.c b/libguile/finalizers.c index 0f3f7a5cc..8b680d68c 100644 --- a/libguile/finalizers.c +++ b/libguile/finalizers.c @@ -40,6 +40,7 @@ #include "gsubr.h" #include "init.h" #include "numbers.h" +#include "ports.h" #include "struct.h" #include "smob.h" #include "threads.h" @@ -460,6 +461,15 @@ scm_set_automatic_finalization_enabled (int enabled_p) } int +scm_i_print_finalizer (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + scm_puts ("#<finalizer ", port); + scm_uintprint (SCM_UNPACK (exp), 16, port); + scm_puts (")>", port); + return 1; +} + +int scm_run_finalizers (void) { int finalized = GC_invoke_finalizers (); diff --git a/libguile/finalizers.h b/libguile/finalizers.h index 941849f6e..6934a21d7 100644 --- a/libguile/finalizers.h +++ b/libguile/finalizers.h @@ -48,6 +48,8 @@ SCM_INTERNAL int scm_i_is_finalizer_thread (struct scm_thread *thread); SCM_API int scm_set_automatic_finalization_enabled (int enabled_p); SCM_API int scm_run_finalizers (void); +SCM_INTERNAL int scm_i_print_finalizer (SCM exp, SCM port, + scm_print_state *pstate SCM_UNUSED); SCM_INTERNAL void scm_register_finalizers (void); SCM_INTERNAL void scm_init_finalizers (void); SCM_INTERNAL void scm_init_finalizer_thread (void); diff --git a/libguile/goops.c b/libguile/goops.c index 8d8b0a3fa..1ce1a490b 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -134,6 +134,7 @@ static SCM class_uvec; static SCM class_array; static SCM class_thread; static SCM class_bitvector; +static SCM class_finalizer; static SCM vtable_class_map = SCM_BOOL_F; @@ -257,6 +258,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_array; case scm_tc7_bitvector: return class_bitvector; + case scm_tc7_finalizer: + return class_finalizer; case scm_tc7_thread: return class_thread; case scm_tc7_string: @@ -940,6 +943,7 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, class_array = scm_variable_ref (scm_c_lookup ("<array>")); class_thread = scm_variable_ref (scm_c_lookup ("<thread>")); class_bitvector = scm_variable_ref (scm_c_lookup ("<bitvector>")); + class_finalizer = scm_variable_ref (scm_c_lookup ("<finalizer>")); class_number = scm_variable_ref (scm_c_lookup ("<number>")); class_complex = scm_variable_ref (scm_c_lookup ("<complex>")); class_real = scm_variable_ref (scm_c_lookup ("<real>")); diff --git a/libguile/print.c b/libguile/print.c index 58b88e908..44204b2d3 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -39,6 +39,7 @@ #include "continuations.h" #include "control.h" #include "eval.h" +#include "finalizers.h" #include "fluids.h" #include "foreign.h" #include "frames.h" @@ -760,6 +761,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_bitvector: scm_i_print_bitvector (exp, port, pstate); break; + case scm_tc7_finalizer: + scm_i_print_finalizer (exp, port, pstate); + break; case scm_tc7_thread: scm_i_print_thread (exp, port, pstate); break; diff --git a/libguile/scm.h b/libguile/scm.h index 4974b571c..b215993e8 100644 --- a/libguile/scm.h +++ b/libguile/scm.h @@ -498,7 +498,7 @@ typedef uintptr_t scm_t_bits; #define scm_tc7_weak_table 0x57 #define scm_tc7_array 0x5d #define scm_tc7_bitvector 0x5f -#define scm_tc7_unused_65 0x65 +#define scm_tc7_finalizer 0x65 #define scm_tc7_unused_67 0x67 #define scm_tc7_unused_6d 0x6d #define scm_tc7_unused_6f 0x6f diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 098803be3..1d05225e9 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -69,7 +69,8 @@ <boolean> <char> <list> <pair> <null> <string> <symbol> <vector> <bytevector> <uvec> <foreign> <hashtable> <fluid> <dynamic-state> <frame> <vm> <vm-continuation> - <keyword> <syntax> <atomic-box> <thread> + <keyword> <syntax> <atomic-box> <thread> <bitvector> + <finalizer> ;; Numbers. <number> <complex> <real> <integer> <fraction> @@ -82,7 +83,7 @@ ;; once you have an instance. Perhaps FIXME to provide a ;; smob-type-name->class procedure. <promise> <mutex> <condition-variable> - <regexp> <hook> <bitvector> <random-state> + <regexp> <hook> <random-state> <directory> <array> <character-set> <dynamic-object> <guardian> <macro> @@ -1078,6 +1079,7 @@ slots as we go." (define-standard-class <uvec> (<bytevector>)) (define-standard-class <array> (<top>)) (define-standard-class <bitvector> (<top>)) +(define-standard-class <finalizer> (<top>)) (define-standard-class <thread> (<top>)) (define-standard-class <number> (<top>)) (define-standard-class <complex> (<number>)) diff --git a/module/system/base/types/internal.scm b/module/system/base/types/internal.scm index a30a73bbc..24e8e14c9 100644 --- a/module/system/base/types/internal.scm +++ b/module/system/base/types/internal.scm @@ -153,7 +153,7 @@ (weak-table weak-table? #b1111111 #b1010111) (array array? #b1111111 #b1011101) (bitvector bitvector? #b1111111 #b1011111) - ;;(unused unused #b1111111 #b1100101) + (finalizer finalizer? #b1111111 #b1100101) ;;(unused unused #b1111111 #b1100111) ;;(unused unused #b1111111 #b1101101) ;;(unused unused #b1111111 #b1101111) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index c9435c6bd..6bfb703f2 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -137,6 +137,7 @@ emit-weak-table? emit-array? emit-bitvector? + emit-finalizer? emit-port? emit-smob? emit-bignum? |