diff --git a/code/final.lisp b/code/final.lisp new file mode 100644 index 0000000000000000000000000000000000000000..aa3aeac4861eed585aec58bd7c023c0dfc9ec9da --- /dev/null +++ b/code/final.lisp @@ -0,0 +1,60 @@ +;;; -*- Package: EXTENSIONS -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/final.lisp,v 1.1 1991/11/16 01:59:18 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Finalization based on weak pointers. Written by William Lott, but +;;; the idea really was Chris Hoover's. +;;; + +(in-package "EXTENSIONS") + +(export '(finalize cancel-finalization)) + +(defvar *objects-pending-finalization* nil) + +(defun finalize (object function) + "Arrage for FUNCTION to be called when there are no more references to + OBJECT." + (declare (type function function)) + (system:without-gcing + (push (cons (make-weak-pointer object) function) + *objects-pending-finalization*)) + object) + +(defun cancel-finalization (object) + "Cancel any finalization registers for OBJECT." + (when object + ;; We check to make sure object isn't nil because if there are any + ;; broken weak pointers, their value will show up as nil. Therefore, + ;; they would be deleted from the list, but not finalized. Broken + ;; weak pointers shouldn't be left in the list, but why take chances? + (system:without-gcing + (setf *objects-pending-finalization* + (delete object *objects-pending-finalization* + :key #'(lambda (pair) + (values (weak-pointer-value (car pair)))))))) + nil) + +(defun finalize-corpses () + (setf *objects-pending-finalization* + (delete-if #'(lambda (pair) + (multiple-value-bind + (object valid) + (weak-pointer-value (car pair)) + (declare (ignore object)) + (unless valid + (funcall (cdr pair)) + t))) + *objects-pending-finalization*)) + nil) + +(pushnew 'finalize-corpses *after-gc-hooks*)