SICP問題3.25

値が任意個数のキーで格納され、値が異なればキーの個数も異なるかも知れない表の実装
insert!, lookupはアクセスするのにキーのリストを取るということなのでこんな感じで。

(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-iter key-list records)
      (if (null? key-list)
          #f
          (let ((subtable (local-assoc (car key-list) (cdr records))))
            (if subtable
                (if (null? (cdr key-list))
                    (cdr subtable)
                  (lookup-iter (cdr key-list) subtable))
                #f))))
    (define (lookup key-list)
      (lookup-iter key-list local-table))
    (define (insert-iter! key-list value records)
      (if (null? key-list)
          #f
          (let ((subtable (local-assoc (car key-list) (cdr records))))
            (if subtable
                (if (null? (cdr key-list))
                    (set-cdr! subtable value)
                    (insert-iter! (cdr key-list) value subtable))
                (if (null? (cdr key-list))
                    (set-cdr! records
                              (cons (cons (car key-list) value)
                                    (cdr records)))
                    (let ((new-table (list (car key-list))))
                      (set-cdr! records
                                (cons new-table
                                      (cdr records)))
                      (insert-iter! (cdr key-list) value new-table)))))))
    (define (insert! key-list value)
      (insert-iter! key-list value 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
((x 'insert-proc!) '(1) 'a)
; ok
((x 'insert-proc!) '(2) 'b)
; ok
((x 'lookup-proc) '(1))
; a
((x 'lookup-proc) '(2))
; b
((x 'insert-proc!) '(1) 'c)
; ok
((x 'lookup-proc) '(1))
; c
((x 'insert-proc!) '(3 1) 'x)
; ok
((x 'lookup-proc) '(3 1))
; x
((x 'insert-proc!) '(4 1 4) 'y)
; ok
((x 'lookup-proc) '(4 1 4))
; y

以下のように値がすでに設定されているキーに対して、更に深い階層の検索や挿入をしようとするケースはエラーとなる。(上からの続きで)

((x 'insert-proc!) '(1 1) 'a)
; *** ERROR: pair required, but got c
; Stack Trace:
; _______________________________________
;   0  same-key?
; 
;   1  local-assoc
; 
;   2  (insert-iter! (cdr key-list) value new-table)
;         At line 36 of "c:\\home\\tmurata\\scheme\\3.25-3.scm"
((x 'lookup-proc) '(1 2))
; *** ERROR: pair required, but got c
; Stack Trace:
; _______________________________________
;   0  same-key?
; 
;   1  local-assoc
; 

というところで悩んでいたんですが、Webで他の人の答え見ても同じっぽかったので、これでOKということで。