SICP問題3.24

equal?でなくsame-key?を使用するassoc手続き(local-assoc)を追加した局所表の定義

(define (make-table same-key?)
  (let ((local-table (list '*table*)))
    (define (local-assoc key records)
      (cond ((null? records) #f)
            ((same-key? key (caar records)) (car records))
            (else (local-assoc key (cdr records)))))
    (define (lookup key-1 key-2)
      (let ((subtable (local-assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (local-assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  #f))
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (local-assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (local-assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))
                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

テスト

(define x (make-table =))
((x 'insert-proc!) 1 1 'a)
; ok
((x 'insert-proc!) 1 2 'b)
; ok
((x 'insert-proc!) 1 3 'c)
; ok
((x 'insert-proc!) 1 4 'd)
; ok
((x 'lookup-proc) 1 2)
; b
((x 'insert-proc!) 1 2.0 'x)
; ok
((x 'lookup-proc) 1 2)
; x

OK