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 / sf / table.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  121 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: table.scm,v 4.5 1999/01/02 06:19:10 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. (declare (usual-integrations)
  23.      (automagic-integrations)
  24.      (open-block-optimizations)
  25.      (eta-substitution))
  26.  
  27. ;;; simple table abstraction
  28. ;;;
  29. ;;; A table is a mutable mapping from key to value.  There is a
  30. ;;; comparison function to determine whether two keys are the same
  31.  
  32. ;;; A table is a 4 tuple consisting of a get-function, a put-function,
  33. ;;; a remove-function, and a function to handle anything else.
  34. ;;;
  35.  
  36. ;;; My big problem with this is that we have to go through the continuation
  37. ;;; passing style get function whether we want to or not.
  38.  
  39. (define-structure (table (conc-name %table-)
  40.              (constructor %make-table))
  41.   (get-function false read-only true)
  42.   (put!-function false read-only true)
  43.   (remove!-function false read-only true)
  44.   (anything-else false read-only true))
  45.  
  46. (define-integrable (table-get table key if-found if-not-found)
  47.   ((%table-get-function table) key if-found if-not-found))
  48.  
  49. (define-integrable (table-put! table key value)
  50.   ((%table-put!-function table) key value))
  51.  
  52. (define-integrable (table-remove! table key)
  53.   ((%table-remove!-function table) key))
  54.  
  55. (define-integrable (table-function table operation arglist)
  56.   ((%table-anything-else table) operation arglist))
  57.  
  58. (define (table-get-chain key1 if-found if-not-found . tables)
  59.   (let loop ((table-list tables)
  60.          (key        key1))
  61.     (if (null? table-list)
  62.     (if-found key)
  63.     (table-get (car table-list) key
  64.       (lambda (value) 
  65.         (loop (cdr table-list) value))
  66.       if-not-found))))
  67.  
  68. (define (table-get-list table keylist)
  69.   (map (lambda (key)
  70.      (table-get table key 
  71.             identity-procedure
  72.             (lambda () #f)))
  73.        keylist))
  74.  
  75. ;;; Returns a table
  76.  
  77. (define (make-generic-eq?-table)
  78.   (let ((the-table '()))
  79.  
  80.     (declare (integrate make-entry 
  81.             entry-value
  82.             set-entry-value!
  83.             lookup 
  84.             extend-table!))
  85.  
  86.     (define make-entry cons)
  87.     (define entry-value cdr)
  88.     (define set-entry-value! set-cdr!)
  89.  
  90.     (define (lookup key)
  91.       (declare (integrate key))
  92.       (assq key the-table))
  93.  
  94.     (define (extend-table! entry)
  95.       (declare (integrate entry))
  96.       (set! the-table (cons entry the-table)))
  97.  
  98.     ;; User functions
  99.  
  100.     (define (get key if-found if-not-found)
  101.       (let ((entry (lookup key)))
  102.     (if (not entry)
  103.         (if-not-found)
  104.         (if-found (entry-value entry)))))
  105.  
  106.     (define (put! key value)
  107.       (let ((entry (lookup key)))
  108.     (if (not entry)
  109.         (extend-table! (make-entry key value))
  110.         (set-entry-value! entry value))))
  111.  
  112.     (define (remove! key)
  113.       (set! the-table (del-assq key the-table)))
  114.  
  115.     (define (dispatch message args)
  116.       args
  117.       (case message
  118.     ((predicate) eq?)
  119.     (else (error "Don't understand that message"))))
  120.  
  121.     (%make-table get put! remove! dispatch)))