Skip to content
Snippets Groups Projects
Forked from cmucl / cmucl
6877 commits behind the upstream repository.
final.lisp 1.89 KiB
;;; -*- 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.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/final.lisp,v 1.2 1994/10/31 04:11:27 ram Rel $")
;;;
;;; **********************************************************************
;;;
;;; 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*)