home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / final.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  2.0 KB  |  61 lines
  1. ;;; -*- Package: EXTENSIONS -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: final.lisp,v 1.1 91/11/16 01:59:18 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Finalization based on weak pointers.  Written by William Lott, but
  15. ;;; the idea really was Chris Hoover's.
  16. ;;;
  17.  
  18. (in-package "EXTENSIONS")
  19.  
  20. (export '(finalize cancel-finalization))
  21.  
  22. (defvar *objects-pending-finalization* nil)
  23.  
  24. (defun finalize (object function)
  25.   "Arrage for FUNCTION to be called when there are no more references to
  26.    OBJECT."
  27.   (declare (type function function))
  28.   (system:without-gcing
  29.    (push (cons (make-weak-pointer object) function)
  30.      *objects-pending-finalization*))
  31.   object)
  32.  
  33. (defun cancel-finalization (object)
  34.   "Cancel any finalization registers for OBJECT."
  35.   (when object
  36.     ;; We check to make sure object isn't nil because if there are any
  37.     ;; broken weak pointers, their value will show up as nil.  Therefore,
  38.     ;; they would be deleted from the list, but not finalized.  Broken
  39.     ;; weak pointers shouldn't be left in the list, but why take chances?
  40.     (system:without-gcing
  41.      (setf *objects-pending-finalization*
  42.        (delete object *objects-pending-finalization*
  43.            :key #'(lambda (pair)
  44.                 (values (weak-pointer-value (car pair))))))))
  45.   nil)
  46.  
  47. (defun finalize-corpses ()
  48.   (setf *objects-pending-finalization*
  49.     (delete-if #'(lambda (pair)
  50.                (multiple-value-bind
  51.                (object valid)
  52.                (weak-pointer-value (car pair))
  53.              (declare (ignore object))
  54.              (unless valid
  55.                (funcall (cdr pair))
  56.                t)))
  57.            *objects-pending-finalization*))
  58.   nil)
  59.  
  60. (pushnew 'finalize-corpses *after-gc-hooks*)
  61.