home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / gcfinal.scm < prev    next >
Text File  |  2000-04-10  |  6KB  |  163 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: gcfinal.scm,v 14.2 2000/04/10 19:10:53 cph Exp $
  4.  
  5. Copyright (c) 2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Garbage Finalization
  23. ;;; package: (runtime gc-finalizer)
  24.  
  25. ;;; These will cause problems on interpreted systems, due to the
  26. ;;; consing of the interpreter.  For now we'll only run this compiled.
  27.  
  28. (declare (usual-integrations))
  29.  
  30. (define-structure (gc-finalizer (constructor %make-gc-finalizer
  31.                          (procedure reset-on-restore?)))
  32.   (procedure #f read-only #t)
  33.   (reset-on-restore? #f read-only #t)
  34.   (items '()))
  35.  
  36. (define (guarantee-gc-finalizer object procedure)
  37.   (if (not (gc-finalizer? object))
  38.       (error:wrong-type-argument object "GC finalizer" procedure)))
  39.  
  40. (define (make-gc-finalizer procedure #!optional reset-on-restore?)
  41.   (if (not (procedure? procedure))
  42.       (error:wrong-type-argument procedure "procedure" 'MAKE-GC-FINALIZER))
  43.   (if (not (procedure-arity-valid? procedure 1))
  44.       (error:bad-range-argument procedure 'MAKE-GC-FINALIZER))
  45.   (let ((finalizer
  46.      (%make-gc-finalizer procedure
  47.                  (if (default-object? reset-on-restore?)
  48.                  #t
  49.                  reset-on-restore?))))
  50.     (set! gc-finalizers (weak-cons finalizer gc-finalizers))
  51.     finalizer))
  52.  
  53. (define (add-to-gc-finalizer! finalizer object context)
  54.   (guarantee-gc-finalizer finalizer 'ADD-TO-GC-FINALIZER!)
  55.   (if (object-pointer? object)
  56.       (without-interrupts
  57.        (lambda ()
  58.      (set-gc-finalizer-items!
  59.       finalizer
  60.       (cons (weak-cons object context)
  61.         (gc-finalizer-items finalizer)))))))
  62.  
  63. (define (remove-from-gc-finalizer! finalizer object)
  64.   (guarantee-gc-finalizer finalizer 'REMOVE-FROM-GC-FINALIZER!)
  65.   (and (object-pointer? object)
  66.        (let ((procedure (gc-finalizer-procedure finalizer)))
  67.      (without-interrupts
  68.       (lambda ()
  69.         (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
  70.           (and (pair? items)
  71.            (if (eq? object (weak-car (car items)))
  72.                (let ((next (cdr items)))
  73.              (if prev
  74.                  (set-cdr! prev next)
  75.                  (set-gc-finalizer-items! finalizer next))
  76.              (procedure (weak-cdr (car items))))
  77.                (loop (cdr items) items)))))))))
  78.  
  79. (define (remove-all-from-gc-finalizer! finalizer)
  80.   (guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!)
  81.   (let ((procedure (gc-finalizer-procedure finalizer)))
  82.     (without-interrupts
  83.      (lambda ()
  84.        (let loop ()
  85.      (let ((items (gc-finalizer-items finalizer)))
  86.        (if (pair? items)
  87.            (begin
  88.          (set-gc-finalizer-items! finalizer (cdr items))
  89.          (let ((object (weak-cdr (car items))))
  90.            (if object
  91.                (procedure object)))
  92.          (loop)))))))))
  93.  
  94. (define (search-gc-finalizer finalizer predicate)
  95.   (guarantee-gc-finalizer finalizer 'SEARCH-GC-FINALIZER)
  96.   (without-interrupts
  97.    (lambda ()
  98.      (let loop ((items (gc-finalizer-items finalizer)))
  99.        (and (pair? items)
  100.         (let ((object (weak-car (car items))))
  101.           (if (and object (predicate object))
  102.           object
  103.           (loop (cdr items)))))))))
  104.  
  105. (define (gc-finalizer-elements finalizer)
  106.   (guarantee-gc-finalizer finalizer 'GC-FINALIZER-ELEMENTS)
  107.   (without-interrupts
  108.    (lambda ()
  109.      (let loop ((items (gc-finalizer-items finalizer)) (objects '()))
  110.        (if (pair? items)
  111.        (loop (cdr items)
  112.          (let ((object (weak-car (car items))))
  113.            (if object
  114.                (cons object objects)
  115.                objects)))
  116.        (reverse! objects))))))
  117.  
  118. (define gc-finalizers)
  119.  
  120. (define (reset-gc-finalizers)
  121.   (without-interrupts
  122.    (lambda ()
  123.      (walk-gc-finalizers-list
  124.       (lambda (finalizer)
  125.     (if (gc-finalizer-reset-on-restore? finalizer)
  126.         (set-gc-finalizer-items! finalizer '())))))))
  127.  
  128. (define (run-gc-finalizers)
  129.   (walk-gc-finalizers-list
  130.    (lambda (finalizer)
  131.      (let ((procedure (gc-finalizer-procedure finalizer)))
  132.        (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
  133.      (if (pair? items)
  134.          (if (weak-pair/car? (car items))
  135.          (loop (cdr items) items)
  136.          (begin
  137.            (procedure (weak-cdr (car items)))
  138.            (let ((next (cdr items)))
  139.              (if prev
  140.              (set-cdr! prev next)
  141.              (set-gc-finalizer-items! finalizer next))
  142.              (loop next prev))))))))))
  143.  
  144. (define (walk-gc-finalizers-list procedure)
  145.   (let loop ((finalizers gc-finalizers) (prev #f))
  146.     (if (weak-pair? finalizers)
  147.     (let ((finalizer (weak-car finalizers)))
  148.       (if finalizer
  149.           (begin
  150.         (procedure finalizer)
  151.         (loop (weak-cdr finalizers) finalizers))
  152.           (let ((next (weak-cdr finalizers)))
  153.         (if prev
  154.             (weak-set-cdr! prev next)
  155.             (set! gc-finalizers next))
  156.         (loop next prev)))))))
  157.  
  158. (define (initialize-package!)
  159.   (set! gc-finalizers '())
  160.   (add-gc-daemon! run-gc-finalizers))
  161.  
  162. (define (initialize-events!)
  163.   (add-event-receiver! event:after-restore reset-gc-finalizers))