diff --git a/code/purify.lisp b/code/purify.lisp index 28a5daca8a4b990a14e0a57103c1b571f0edab0a..1ced80ba23d4b198f98583784c5f5973caba05d1 100644 --- a/code/purify.lisp +++ b/code/purify.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/purify.lisp,v 1.12 1992/02/14 23:45:24 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/purify.lisp,v 1.13 1992/03/26 03:18:51 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -23,16 +23,19 @@ (read-only-roots c-call:unsigned-long)) (defun purify (&key root-structures constants) - (write-string "[Doing purification: ") - (force-output) - (without-gcing - (clear-auto-gc-trigger) - (%purify (get-lisp-obj-address root-structures) - (get-lisp-obj-address constants)) - (when *gc-trigger* - (setf *gc-trigger* *bytes-consed-between-gcs*) - (set-auto-gc-trigger *gc-trigger*))) - (write-line "Done.]") - (force-output) + (let ((*gc-notify-before* + #'(lambda (bytes-in-use) + (declare (ignore bytes-in-use)) + (write-string "[Doing purification: ") + (force-output))) + (*internal-gc* + #'(lambda () + (%purify (get-lisp-obj-address root-structures) + (get-lisp-obj-address constants)))) + (*gc-notify-after* + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (write-line "Done.]")))) + (gc t)) nil)