summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2025-05-02 16:21:17 +0200
committerAndy Wingo <wingo@pobox.com>2025-05-02 16:26:17 +0200
commitcf25a94745fc733af38db65fa62584ebba92bf93 (patch)
tree14c2f0a8000abddad1191afbc68bd0dab6064294
parent532df66e0734a205d1e65b149bde7e1111c4000b (diff)
downloadguile-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.c1
-rw-r--r--libguile/finalizers.c10
-rw-r--r--libguile/finalizers.h2
-rw-r--r--libguile/goops.c4
-rw-r--r--libguile/print.c4
-rw-r--r--libguile/scm.h2
-rw-r--r--module/oop/goops.scm6
-rw-r--r--module/system/base/types/internal.scm2
-rw-r--r--module/system/vm/assembler.scm1
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?