Add (system finalizers)

This will replace an internal interface in (system foreign-objects).

* module/system/finalizers.scm: New file.
* am/bootstrap.am (SOURCES): Add new file.
* libguile/foreign-object.h:
* libguile/foreign-object.c (invoke_finalizer):
(sys_add_finalizer_x):
(scm_init_foreign_object):
(scm_register_foreign_object): Remove.
* libguile/init.c (scm_i_init_guile): Register finalizers instead of
foreign-object.
* module/system/foreign-object.scm (allocate-instance): Use finalizers
module.
* libguile/finalizers.c (invoke_finalizer):
(scm_sys_add_finalizer): New helper.

am/bootstrap.am

@@ -1,4 +1,4 @@
-##  	Copyright (C) 2009-2024 Free Software Foundation, Inc.
+##  	Copyright (C) 2009-2025 Free Software Foundation, Inc.
 ##
 ##   This file is part of GNU Guile.
 ##
@@ -366,6 +366,7 @@ SOURCES =					\
   system/base/types/internal.scm		\
   system/base/ck.scm				\
 						\
+  system/finalizers.scm				\
   system/foreign.scm				\
   system/foreign-library.scm			\
   system/foreign-object.scm			\

libguile/Makefile.am

@@ -281,6 +281,7 @@ DOT_X_FILES =					\
 	fdes-finalizers.x			\
 	feature.x				\
 	filesys.x				\
+	finalizers.x				\
 	fluids.x				\
 	foreign.x				\
 	fports.x				\

libguile/finalizers.c

@@ -32,12 +32,16 @@
 #include <unistd.h>
 
 #include "async.h"
+#include "atomics-internal.h"
 #include "bdw-gc.h"
+#include "eval.h"
+#include "extensions.h"
 #include "gc.h"
 #include "gsubr.h"
 #include "init.h"
+#include "numbers.h"
 #include "threads.h"
-#include "atomics-internal.h"
+#include "version.h"
 
 #include "finalizers.h"
 
@@ -53,6 +57,13 @@ static SCM run_finalizers_subr;
 
 
 
+enum finalizer_priority
+  {
+    FINALIZER_PRIORITY_GUARDIAN,
+    FINALIZER_PRIORITY_DEFAULT
+  };
+
+
 void
 scm_i_set_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
 {
@@ -139,6 +150,29 @@ scm_i_add_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
   shuffle_resuscitators_to_front (chained_data);
 }
 
+static void
+invoke_finalizer (void *obj, void *data)
+{
+  scm_call_1 (PTR2SCM (data), PTR2SCM (obj));
+}
+
+SCM_DEFINE_STATIC(scm_sys_add_finalizer, "%add-finalizer!", 3, 0, 0,
+                  (SCM obj, SCM proc, SCM priority),
+                  "Add a finalizer @var{proc} to object @var{obj}, with "
+                  "priority @var{priority}.  Return the finalizer object.")
+#define FUNC_NAME s_scm_sys_add_finalizer
+{
+  SCM_MAKE_VALIDATE (1, obj, HEAP_OBJECT_P);
+  SCM_VALIDATE_PROC (2, proc);
+  size_t c_priority = scm_to_unsigned_integer (priority,
+                                               FINALIZER_PRIORITY_GUARDIAN,
+                                               FINALIZER_PRIORITY_DEFAULT);
+
+  (void) c_priority;
+  scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (proc));
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
 
 
 
@@ -447,6 +481,17 @@ scm_run_finalizers (void)
 
 
 
+static void scm_init_finalizers_module (void);
+
+void
+scm_register_finalizers (void)
+{
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_finalizers_module",
+                            (scm_t_extension_init_func)scm_init_finalizers_module,
+                            NULL);
+}
+
 void
 scm_init_finalizers (void)
 {
@@ -459,6 +504,14 @@ scm_init_finalizers (void)
     GC_set_finalizer_notifier (queue_finalizer_async);
 }
 
+static void
+scm_init_finalizers_module (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "finalizers.x"
+#endif
+}
+
 void
 scm_init_finalizer_thread (void)
 {

libguile/finalizers.h

@@ -48,6 +48,7 @@ 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 void scm_register_finalizers (void);
 SCM_INTERNAL void scm_init_finalizers (void);
 SCM_INTERNAL void scm_init_finalizer_thread (void);
 

libguile/foreign-object.c

@@ -1,4 +1,4 @@
-/* Copyright 2014,2017-2018
+/* Copyright 2014,2017-2018,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -25,10 +25,8 @@
 #endif
 
 #include "eval.h"
-#include "extensions.h"
 #include "finalizers.h"
 #include "goops.h"
-#include "gsubr.h"
 #include "list.h"
 #include "modules.h"
 #include "numbers.h"
@@ -196,37 +194,3 @@ scm_foreign_object_set_x (SCM obj, size_t n, void *val)
   scm_t_bits bits = (scm_t_bits) val;
   scm_foreign_object_unsigned_set_x (obj, n, bits);
 }
-  
-static void
-invoke_finalizer (void *obj, void *data)
-{
-  scm_call_1 (PTR2SCM (data), PTR2SCM (obj));
-}
-
-static SCM
-sys_add_finalizer_x (SCM obj, SCM finalizer)
-#define FUNC_NAME "%add-finalizer!"
-{
-  SCM_VALIDATE_PROC (SCM_ARG2, finalizer);
-
-  scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (finalizer));
-
-  return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-static void
-scm_init_foreign_object (void)
-{
-  scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0,
-                      (scm_t_subr) sys_add_finalizer_x);
-}
-
-void
-scm_register_foreign_object (void)
-{
-  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
-                            "scm_init_foreign_object",
-                            (scm_t_extension_init_func)scm_init_foreign_object,
-                            NULL);
-}

libguile/foreign-object.h

@@ -1,7 +1,7 @@
 #ifndef SCM_FOREIGN_OBJECT_H
 #define SCM_FOREIGN_OBJECT_H
 
-/* Copyright 2014,2018
+/* Copyright 2014,2018,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -56,7 +56,5 @@ SCM_API scm_t_signed_bits scm_foreign_object_signed_ref (SCM obj, size_t n);
 SCM_API void scm_foreign_object_signed_set_x (SCM obj, size_t n,
                                               scm_t_signed_bits val);
 
-SCM_INTERNAL void scm_register_foreign_object (void);
-
 
 #endif  /* SCM_FOREIGN_OBJECT_H */

libguile/init.c

@@ -370,8 +370,8 @@ scm_i_init_guile (struct gc_stack_addr base)
   scm_register_atomic ();
   scm_register_custom_ports ();
   scm_register_fdes_finalizers ();
+  scm_register_finalizers ();
   scm_register_foreign ();
-  scm_register_foreign_object ();
   scm_register_srfi_60 ();
   scm_register_poll ();
 

module/system/finalizers.scm

@@ -0,0 +1,34 @@
+;;; Copyright (C) 2025 Free Software Foundation, Inc.
+;;;
+;;; This library is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+
+(define-module (system finalizers)
+  #:export (add-finalizer!
+            %guardian-finalizer-priority
+            %default-finalizer-priority))
+
+(eval-when (expand load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_finalizers_module"))
+
+(define %guardian-finalizer-priority 1)
+(define %default-finalizer-priority 0)
+
+(define* (add-finalizer! obj proc
+                         #:optional (priority %default-finalizer-priority))
+  "Add a finalizer @var{proc} to object @var{obj}, with priority
+@var{priority}.  Return the finalizer object."
+  (%add-finalizer! obj proc priority))

module/system/foreign-object.scm

@@ -1,6 +1,6 @@
 ;;; Wrapping foreign objects in Scheme
 
-;;; Copyright (C) 2014, 2015, 2024 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2024, 2025 Free Software Foundation, Inc.
 ;;; 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -24,13 +24,10 @@
 
 (define-module (system foreign-object)
   #:use-module (oop goops)
+  #:use-module (system finalizers)
   #:export     (make-foreign-object-type
                 define-foreign-object-type))
 
-(eval-when (eval load expand)
-  (load-extension (string-append "libguile-" (effective-version))
-                  "scm_init_foreign_object"))
-
 (define-class <foreign-class> (<class>))
 
 (define-class <foreign-class-with-finalizer> (<foreign-class>)
@@ -42,7 +39,7 @@
   (let ((instance (next-method))
         (finalizer (finalizer class)))
     (when finalizer
-      (%add-finalizer! instance finalizer))
+      (add-finalizer! instance finalizer))
     instance))
 
 (define* (make-foreign-object-type name slots #:key finalizer