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 / poplat.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  137 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: poplat.scm,v 14.4 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 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. ;;;; Populations
  23. ;;; package: (runtime population)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;; A population is a collection of objects.  This collection has the
  28. ;;; property that if one of the objects in the collection is reclaimed
  29. ;;; as garbage, then it is no longer an element of the collection.
  30.  
  31. (define (initialize-package!)
  32.   (set! population-of-populations (cons population-tag '()))
  33.   (add-secondary-gc-daemon! gc-all-populations!))
  34.  
  35. (define (initialize-unparser!)
  36.   (unparser/set-tagged-pair-method! population-tag
  37.                     (standard-unparser-method 'POPULATION #f)))
  38.  
  39. (define bogus-false '(BOGUS-FALSE))
  40. (define population-tag '(POPULATION))
  41. (define-integrable weak-cons-type (ucode-type weak-cons))
  42.  
  43. (define-integrable (canonicalize object)
  44.   (if (eq? object false) bogus-false object))
  45.  
  46. (define-integrable (uncanonicalize object)
  47.   (if (eq? object bogus-false) false object))
  48.  
  49. (define (gc-population! population)
  50.   (let loop ((l1 population) (l2 (cdr population)))
  51.     (cond ((null? l2) true)
  52.       ((eq? (system-pair-car l2) false)
  53.        (system-pair-set-cdr! l1 (system-pair-cdr l2))
  54.        (loop l1 (system-pair-cdr l1)))
  55.       (else (loop l2 (system-pair-cdr l2))))))
  56.  
  57. (define (gc-all-populations!)
  58.   (gc-population! population-of-populations)
  59.   (map-over-population! population-of-populations gc-population!))
  60.  
  61. (define population-of-populations)
  62.  
  63. (define (make-population)
  64.   (let ((population (cons population-tag '())))
  65.     (add-to-population! population-of-populations population)
  66.     population))
  67.  
  68. (define (population? object)
  69.   (and (pair? object)
  70.        (eq? (car object) population-tag)))
  71.  
  72. (define (add-to-population! population object)
  73.   (let ((object (canonicalize object)))
  74.     (let loop ((previous population) (this (cdr population)))
  75.       (if (null? this)
  76.       (set-cdr! population
  77.             (system-pair-cons weak-cons-type
  78.                       object
  79.                       (cdr population)))
  80.       (let ((entry (system-pair-car this))
  81.         (next (system-pair-cdr this)))
  82.         (cond ((not entry)
  83.            (system-pair-set-cdr! previous next)
  84.            (loop previous next))
  85.           ((not (eq? object entry))
  86.            (loop this next))))))))
  87.  
  88. (define (remove-from-population! population object)
  89.   (let ((object (canonicalize object)))
  90.     (let loop ((previous population) (this (cdr population)))
  91.       (if (not (null? this))
  92.       (let ((entry (system-pair-car this))
  93.         (next (system-pair-cdr this)))
  94.         (if (or (not entry) (eq? object entry))
  95.         (begin (system-pair-set-cdr! previous next)
  96.                (loop previous next))
  97.         (loop this next)))))))
  98.  
  99. ;;;; Higher level operations
  100.  
  101. (define (map-over-population population procedure)
  102.   (let loop ((l1 population) (l2 (cdr population)))
  103.     (cond ((null? l2) '())
  104.       ((eq? (system-pair-car l2) false)
  105.        (system-pair-set-cdr! l1 (system-pair-cdr l2))
  106.        (loop l1 (system-pair-cdr l1)))
  107.       (else
  108.        (cons (procedure (uncanonicalize (system-pair-car l2)))
  109.          (loop l2 (system-pair-cdr l2)))))))
  110.  
  111. (define (map-over-population! population procedure)
  112.   (let loop ((l1 population) (l2 (cdr population)))
  113.     (cond ((null? l2) true)
  114.       ((eq? (system-pair-car l2) false)
  115.        (system-pair-set-cdr! l1 (system-pair-cdr l2))
  116.        (loop l1 (system-pair-cdr l1)))
  117.       (else
  118.        (procedure (uncanonicalize (system-pair-car l2)))
  119.        (loop l2 (system-pair-cdr l2))))))
  120.  
  121. (define (for-all-inhabitants? population predicate)
  122.   (let loop ((l1 population) (l2 (cdr population)))
  123.     (or (null? l2)
  124.     (if (eq? (system-pair-car l2) false)
  125.         (begin (system-pair-set-cdr! l1 (system-pair-cdr l2))
  126.            (loop l1 (system-pair-cdr l1)))
  127.         (and (predicate (uncanonicalize (system-pair-car l2)))
  128.          (loop l2 (system-pair-cdr l2)))))))
  129.  
  130. (define (exists-an-inhabitant? population predicate)
  131.   (let loop ((l1 population) (l2 (cdr population)))
  132.     (and (not (null? l2))
  133.      (if (eq? (system-pair-car l2) false)
  134.          (begin (system-pair-set-cdr! l1 (system-pair-cdr l2))
  135.             (loop l1 (system-pair-cdr l1)))
  136.          (or (predicate (uncanonicalize (system-pair-car l2)))
  137.          (loop l2 (system-pair-cdr l2)))))))