src/sicp/local-tables.rkt

   1 #lang r5rs
   2
   3 (define error display)
   4
   5 (define (make-table)
   6   (let ((local-table (list '*table*)))
   7     (define (assoc key records)
   8       (cond
   9         ((null? records) #f)
  10         ((equal? key (car (car records))) (car records))
  11         (else (assoc key (cdr records)))))
  12
  13     (define (lookup key-1 key-2)
  14       (let ((subtable (assoc key-1 (cdr local-table))))
  15         (if subtable
  16             (let ((record (assoc key-2 (cdr subtable))))
  17               (if record
  18                   (cdr record)
  19                   #f))
  20             #f)))
  21     (define (insert! key-1 key-2 value)
  22       (let ((subtable (assoc key-1 (cdr local-table))))
  23         (if subtable
  24             (let ((record (assoc key-2 (cdr subtable))))
  25               (if record
  26                   (set-cdr! record value)
  27                   (set-cdr! subtable
  28                             (cons (cons key-2 value)
  29                                   (cdr subtable)))))
  30             (set-cdr! local-table
  31                       (cons (list key-1
  32                                   (cons key-2 value))
  33                             (cdr local-table)))))
  34       'ok)
  35     (define (dispatch m)
  36       (cond
  37         ((eq? m 'lookup-proc) lookup)
  38         ((eq? m 'insert-proc!) insert!)
  39         (else (error "Unknown operation -- TABLE"))))
  40     dispatch))
  41
  42 (define operation-table (make-table))
  43 (define get (operation-table 'lookup-proc))
  44 (define put (operation-table 'insert-proc!))