From 4adbf9319259d94604c9f5b5d27c3b3e3e0118f0 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 6 Oct 2015 20:58:30 -0700
Subject: New function: call-finalizers.

* gc.c (gc_call_finalizers): New function.
(gc_late_init): Register call-finalizers intrinsic.

* gc.h (gc_call_finalizers): Declared.

* txr.1: documented call-finalizers.
---
 gc.c  | 33 +++++++++++++++++++++++++++++++++
 gc.h  |  1 +
 txr.1 | 17 +++++++++++++++++
 3 files changed, 51 insertions(+)

diff --git a/gc.c b/gc.c
index 4ead33b7..ed8cd04c 100644
--- a/gc.c
+++ b/gc.c
@@ -834,11 +834,44 @@ val gc_finalize(val obj, val fun, val rev_order_p)
   return obj;
 }
 
+val gc_call_finalizers(val obj)
+{
+  struct fin_reg *new_list = 0, *old_list = final_list;
+  struct fin_reg **tail = &new_list, *f, *next;
+  val ret = nil;
+
+  if (!final_list)
+    return ret;
+
+  final_list = 0;
+  final_tail = &final_list;
+
+  for (f = old_list; f; f = next) {
+    next = f->next;
+
+    if (f->obj == obj) {
+      funcall1(f->fun, f->obj);
+      free(f);
+      ret = t;
+    } else {
+      *tail = f;
+      tail = &f->next;
+    }
+  }
+
+  *tail = 0;
+  *final_tail = new_list;
+  final_tail = tail;
+  return ret;
+}
+
 void gc_late_init(void)
 {
   reg_fun(intern(lit("gc"), system_package), func_n0(gc_wrap));
   reg_fun(intern(lit("gc-set-delta"), system_package), func_n1(gc_set_delta));
   reg_fun(intern(lit("finalize"), user_package), func_n3o(gc_finalize, 2));
+  reg_fun(intern(lit("call-finalizers"), user_package),
+          func_n1(gc_call_finalizers));
 }
 
 /*
diff --git a/gc.h b/gc.h
index d7b00a69..183348f8 100644
--- a/gc.h
+++ b/gc.h
@@ -36,6 +36,7 @@ void gc_mark(val);
 void gc_conservative_mark(val);
 int gc_is_reachable(val);
 val gc_finalize(val obj, val fun, val rev_order_p);
+val gc_call_finalizers(val obj);
 
 #if CONFIG_GEN_GC
 val gc_set(loc, val);
diff --git a/txr.1 b/txr.1
index b7bfd01c..092e1469 100644
--- a/txr.1
+++ b/txr.1
@@ -34111,6 +34111,23 @@ or any other object for finalization. Such registrations made during
 finalization execution are not eligible for the current phase of finalization
 processing; they will be processed in a later garbage collection pass.
 
+.coNP Function @ call-finalizers
+.synb
+.mets (call-finalizers << object )
+.syne
+.desc
+The
+.code call-finalizers
+function invokes and removes the finalizers, if any, registered against
+.metn object .
+If any finalizers are called, it returns
+.codn t ,
+otherwise
+.code nil .
+
+Note: the behavior is unspecified if a finalizer function calls
+.codn call-finalizers .
+
 .SS* Modularization
 .coNP Variable @ self-path
 .desc
-- 
cgit v1.2.3