From b1ca967ecb9a0691a05c0d236ba956b209e3cbe7 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Thu, 20 May 1993 13:45:06 +0000
Subject: [PATCH] Added stuff to fake scavenger hooks in the non-gengc system.

---
 code/scavhook.lisp | 80 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 79 insertions(+), 1 deletion(-)

diff --git a/code/scavhook.lisp b/code/scavhook.lisp
index 78851b051..2b57d1221 100644
--- a/code/scavhook.lisp
+++ b/code/scavhook.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/scavhook.lisp,v 1.1 1991/07/30 00:40:04 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/scavhook.lisp,v 1.2 1993/05/20 13:45:06 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,6 +21,9 @@
 (export '(scavenger-hook scavenger-hook-p make-scavenger-hook
 	  scavenger-hook-value scavenger-hook-function))
 
+#+gengc
+(progn
+
 (defun scavenger-hook-p (object)
   "Returns T if OBJECT is a scavenger-hook, and NIL if not."
   (scavenger-hook-p object))
@@ -53,3 +56,78 @@
 	   (type scavenger-hook scavhook))
   (setf (scavenger-hook-function scavhook) function))
 
+); #+gengc progn
+
+#-gengc
+(progn
+
+(defstruct (scavhook
+	    (:conc-name scavenger-hook-)
+	    (:constructor %make-scavenger-hook (%value function last-addr))
+	    (:print-function %print-scavenger-hook))
+  ;;
+  ;; The value we are monitoring.
+  (%value nil :type t)
+  ;;
+  ;; The function to invoke when the value gets scavenged (i.e. moved)
+  (function nil :type function)
+  ;;
+  ;; The address of where it was last time.
+  (last-addr 0 :type (unsigned-byte #.vm:word-bits)))
+
+(defun %print-scavenger-hook (scavhook stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (scavhook stream :identity t :type t)))
+
+(eval-when (compile eval)
+  (setf (info type kind 'scavenger-hook) :defined)
+  (setf (info type builtin 'scavenger-hook) nil))
+
+(deftype scavenger-hook ()
+  'scavhook)
+
+(defvar *scavenger-hooks* nil)
+
+(defun make-scavenger-hook (&key value (function (required-argument)))
+  (without-gcing
+    (let ((scavhook
+	   (%make-scavenger-hook value function
+				 (kernel:get-lisp-obj-address value))))
+      (push (make-weak-pointer scavhook) *scavenger-hooks*)
+      scavhook)))
+
+(declaim (inline scavenger-hook-p))
+(defun scavenger-hook-p (thing)
+  (scavhook-p thing))
+
+(declaim (inline scavenger-hook-value))
+(defun scavenger-hook-value (scavhook)
+  (scavenger-hook-%value scavhook))
+
+(defun (setf scavenger-hook-value) (value scavhook)
+  (without-gcing
+    (setf (scavenger-hook-%value scavhook) value)
+    (setf (scavenger-hook-last-addr scavhook)
+	  (kernel:get-lisp-obj-address value)))
+  value)
+
+(defun scavhook-after-gc-hook ()
+  (do ((prev nil)
+       (next *scavenger-hooks* (cdr next)))
+      ((null next))
+    (multiple-value-bind (scavhook valid) (weak-pointer-value (car next))
+      (cond (valid
+	     (let* ((value (scavenger-hook-value scavhook))
+		    (addr (kernel:get-lisp-obj-address value)))
+	       (unless (= addr (scavenger-hook-last-addr scavhook))
+		 (setf (scavenger-hook-last-addr scavhook) addr)
+		 (funcall (scavenger-hook-function scavhook))))
+	     (setf prev next))
+	    (prev
+	     (setf (cdr prev) (cdr next)))
+	    (t
+	     (setf *scavenger-hooks* (cdr next)))))))
+
+(pushnew 'scavhook-after-gc-hook *after-gc-hooks*)
+
+); #-gengc progn
-- 
GitLab