home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / hash.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  5.0 KB  |  168 lines  |  [TEXT/gamI]
  1. ; -*-Scheme-*-
  2. ;
  3. ; $Id: gambit_hash.scm,v 1.2 1992/09/23 15:24:00 birkholz Exp $
  4. ; $MIT-Header: prop1d.scm,v 14.4 89/09/15 17:16:35 GMT jinx Exp $
  5. ;
  6. ; Copyright (c) 1988, 1989 Massachusetts Institute of Technology
  7. ;
  8. ; This material was developed by the Scheme project at the Massachusetts
  9. ; Institute of Technology, Department of Electrical Engineering and
  10. ; Computer Science.  Permission to copy this software, to redistribute
  11. ; it, and to use it for any purpose is granted, subject to the following
  12. ; restrictions and understandings.
  13. ;
  14. ; 1. Any copy made of this software must include this copyright notice
  15. ; in full.
  16. ;
  17. ; 2. Users of this software agree to make their best efforts (a) to
  18. ; return to the MIT Scheme project any improvements or extensions that
  19. ; they make, so that these may be included in future releases; and (b)
  20. ; to inform MIT of noteworthy uses of this software.
  21. ; 
  22. ; 3. All materials developed as a consequence of the use of this
  23. ; software shall duly acknowledge such use, in accordance with the usual
  24. ; standards of acknowledging credit in academic research.
  25. ;
  26. ; 4. MIT has made no warrantee or representation that the operation of
  27. ; this software will be error-free, and MIT is under no obligation to
  28. ; provide any services, by way of maintenance, update, or otherwise.
  29. ;
  30. ; 5. In conjunction with products arising from the use of this material,
  31. ; there shall be no use of the name of the Massachusetts Institute of
  32. ; Technology nor of any adaptation thereof in any advertising,
  33. ; promotional, or sales literature without prior written consent from
  34. ; MIT in each case.
  35.  
  36. ; This file requires the following non-IEEE primitives:
  37.  
  38. ; ##weak-cons, ##weak-car, ##weak-cdr, ##weak-set-cdr! for manipulating
  39. ; "weak-cons cells," whose cdr is normal but whose car turns to #F
  40. ; during a garbage collection if no non-weak references are found to
  41. ; the object in the car.
  42.  
  43. ; ##add-gc-finalize-job registers a thunk (procedure of no arguments) to be
  44. ; called after each garbage collection is complete and before Scheme resumes
  45. ; running.
  46.  
  47. ;;;; One Dimensional Property Tables
  48.  
  49. (define (initialize-oned-table-package!)
  50.   (set! population-of-oned-tables (make-population))
  51.   (##add-gc-finalize-job ; setup GC finalization
  52.     gc-oned-tables!))
  53.  
  54. (define population-of-oned-tables #f)
  55.  
  56. (define (gc-oned-tables!)
  57.   (map-over-population! population-of-oned-tables oned-table/clean!))
  58.  
  59. (define (make-oned-table)
  60.   (let ((table (list oned-table-tag)))
  61.     (add-to-population! population-of-oned-tables table)
  62.     table))
  63.  
  64. (define (oned-table? object)
  65.   (and (pair? object)
  66.        (eq? (car object) oned-table-tag)))
  67.  
  68. (define oned-table-tag
  69.   "1D table")
  70.  
  71. (define false-key
  72.   "false key")
  73.  
  74. (define (weak-assq key table)
  75.   (let loop ((previous table) (alist (cdr table)))
  76.     (and (not (null? alist))
  77.      (let ((entry (car alist))
  78.            (next (cdr alist)))
  79.        (let ((key* (##weak-car entry)))
  80.          (cond ((not key*)
  81.             (set-cdr! previous next)
  82.             (loop previous next))
  83.            ((eq? key* key)
  84.             entry)
  85.            (else
  86.             (loop alist next))))))))
  87.  
  88. (define (oned-table/get table key default)
  89.   (let ((entry (weak-assq (or key false-key) table)))
  90.     (if entry
  91.     (##weak-cdr entry)
  92.     default)))
  93.  
  94. (define (oned-table/lookup table key if-found if-not-found)
  95.   (let ((entry (weak-assq (or key false-key) table)))
  96.     (if entry
  97.     (if-found (##weak-cdr entry))
  98.     (if-not-found))))
  99.  
  100. (define (oned-table/put! table key value)
  101.   (let ((key (or key false-key)))
  102.     (let ((entry (weak-assq key table)))
  103.       (if entry
  104.       (##weak-set-cdr! entry value)
  105.       (set-cdr! table
  106.             (cons (##weak-cons key value)
  107.               (cdr table))))
  108.       #f)))
  109.  
  110. (define (oned-table/remove! table key)
  111.   (let ((key (or key false-key)))
  112.     (let loop ((previous table) (alist (cdr table)))
  113.       (if (not (null? alist))
  114.       (let ((key* (##weak-car (car alist)))
  115.         (next (cdr alist)))
  116.         (loop (if (or (not key*) (eq? key* key))
  117.               ;; Might as well clean whole list.
  118.               (begin
  119.             (set-cdr! previous next)
  120.             previous)
  121.               alist)
  122.           next))))))
  123.  
  124. (define (oned-table/clean! table)
  125.   (let loop ((previous table) (alist (cdr table)))
  126.     (if (not (null? alist))
  127.     (let ((next (cdr alist)))
  128.       (loop (if (##weak-car (car alist))
  129.             alist
  130.             (begin
  131.               (set-cdr! previous next)
  132.               previous))
  133.         next)))))
  134.  
  135. (define (oned-table/alist table)
  136.   (let loop ((previous table) (alist (cdr table)) (result '()))
  137.     (if (null? alist)
  138.     result
  139.     (let ((entry (car alist))
  140.           (next (cdr alist)))
  141.       (let ((key (##weak-car entry)))
  142.         (if (not key)
  143.         (begin
  144.           (set-cdr! previous next)
  145.           (loop previous next result))
  146.         (loop alist
  147.               next
  148.               (cons (cons (and (not (eq? key false-key)) key)
  149.                   (##weak-cdr entry))
  150.                 result))))))))
  151.  
  152. (define (oned-table/for-each proc table)
  153.   (let loop ((previous table) (alist (cdr table)))
  154.     (if (not (null? alist))
  155.     (let ((entry (car alist))
  156.           (next (cdr alist)))
  157.       (let ((key (##weak-car entry)))
  158.         (if key
  159.         (begin
  160.           (proc (and (not (eq? key false-key)) key)
  161.             (##weak-cdr entry))
  162.           (loop alist next))
  163.         (begin
  164.           (set-cdr! previous next)
  165.           (loop previous next))))))))
  166.  
  167. (initialize-oned-table-package!)
  168.