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 / prop2d.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  114 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: prop2d.scm,v 14.3 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. ;;;; Two Dimensional Property Tables
  23. ;;; package: (runtime 2D-property)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! system-properties '())
  29.   (set! delete-invalid-hash-numbers! (list-deletor! filter-bucket!))
  30.   (set! delete-invalid-y! (list-deletor! filter-entry!))
  31.   (add-secondary-gc-daemon! gc-system-properties!))
  32.  
  33. (define system-properties)
  34.  
  35. (define (2D-put! x y value)
  36.   (let ((x-hash (object-hash x))
  37.     (y-hash (object-hash y)))
  38.     (let ((bucket (assq x-hash system-properties)))
  39.       (if bucket
  40.       (let ((entry (assq y-hash (cdr bucket))))
  41.         (if entry
  42.         (set-cdr! entry value)
  43.         (set-cdr! bucket
  44.               (cons (cons y-hash value)
  45.                 (cdr bucket)))))
  46.       (set! system-properties
  47.         (cons (cons x-hash
  48.                 (cons (cons y-hash value)
  49.                   '()))
  50.               system-properties))))))
  51.  
  52. (define (2D-get x y)
  53.   (let ((bucket (assq (object-hash x) system-properties)))
  54.     (and bucket
  55.      (let ((entry (assq (object-hash y) (cdr bucket))))
  56.        (and entry
  57.         (cdr entry))))))
  58.  
  59. ;;; Returns TRUE iff an entry was removed.
  60. ;;; Removes the bucket if the entry removed was the only entry.
  61.  
  62. (define (2D-remove! x y)
  63.   (let ((bucket (assq (object-hash x) system-properties)))
  64.     (and bucket
  65.      (begin (set-cdr! bucket
  66.               (del-assq! (object-hash y)
  67.                      (cdr bucket)))
  68.         (if (null? (cdr bucket))
  69.             (set! system-properties
  70.               (del-assq! (object-hash x)
  71.                      system-properties)))
  72.         true))))
  73.  
  74. ;;; This clever piece of code removes all invalid entries and buckets,
  75. ;;; and also removes any buckets which [subsequently] have no entries.
  76.  
  77. (define (gc-system-properties!)
  78.   (set! system-properties (delete-invalid-hash-numbers! system-properties)))
  79.  
  80. (define (filter-bucket! bucket)
  81.   (or (not (valid-hash-number? (car bucket)))
  82.       (begin (set-cdr! bucket (delete-invalid-y! (cdr bucket)))
  83.          (null? (cdr bucket)))))
  84.  
  85. (define (filter-entry! entry)
  86.   (not (valid-hash-number? (car entry))))
  87.  
  88. (define delete-invalid-hash-numbers!)
  89. (define delete-invalid-y!)
  90.  
  91. (define (2D-get-alist-x x)
  92.   (let ((bucket (assq (object-hash x) system-properties)))
  93.     (if bucket
  94.     (let loop ((rest (cdr bucket)))
  95.       (cond ((null? rest) '())
  96.         ((valid-hash-number? (caar rest))
  97.          (cons (cons (object-unhash (caar rest))
  98.                  (cdar rest))
  99.                (loop (cdr rest))))
  100.         (else (loop (cdr rest)))))
  101.     '())))
  102.  
  103. (define (2D-get-alist-y y)
  104.   (let ((y-hash (object-hash y)))
  105.     (let loop ((rest system-properties))
  106.       (cond ((null? rest) '())
  107.         ((valid-hash-number? (caar rest))
  108.          (let ((entry (assq y-hash (cdar rest))))
  109.            (if entry
  110.            (cons (cons (object-unhash (caar rest))
  111.                    (cdr entry))
  112.              (loop (cdr rest)))
  113.            (loop (cdr rest)))))
  114.         (else (loop (cdr rest)))))))