51 lines
1.4 KiB
Racket
51 lines
1.4 KiB
Racket
#lang sicp
|
|
|
|
(#%require "table.rkt")
|
|
(#%provide make-dispatch-table
|
|
put!
|
|
put-alist!
|
|
get)
|
|
|
|
|
|
(define (assoc key records)
|
|
(cond ((null? records) false)
|
|
((equal? key (caar records)) (car records))
|
|
(else (assoc key (cdr records)))))
|
|
|
|
(define (make-dispatch-table)
|
|
(let ((local-table (list '*dispatch-table*)))
|
|
(define (get sym)
|
|
(let ((value (assoc sym (cdr local-table))))
|
|
(if value
|
|
(cdr value)
|
|
#f)))
|
|
;; We are using alists, so the newest association
|
|
;; is always found, so there is no need to overwrite
|
|
;; an existing binding.
|
|
(define (put! sym proc)
|
|
(set-cdr! local-table
|
|
(cons
|
|
(cons sym proc)
|
|
(cdr local-table))))
|
|
(define (put-alist! sym-proc-alist)
|
|
(if (not (null? sym-proc-alist))
|
|
(let ((sym (caar sym-proc-alist))
|
|
(proc (cdar sym-proc-alist)))
|
|
(put! sym proc)
|
|
(put-alist! (cdr sym-proc-alist)))))
|
|
(define (dispatch m)
|
|
(cond ((eq? m 'get) get)
|
|
((eq? m 'put!) put!)
|
|
((eq? m 'put-alist!) put-alist!)
|
|
(else (error "Unknown operation -- DISPATCH-TABLE" m))))
|
|
dispatch))
|
|
|
|
(define (put! table key proc)
|
|
((table 'put!) key proc))
|
|
|
|
(define (put-alist! table sym-proc-alist)
|
|
((table 'put-alist!) sym-proc-alist))
|
|
|
|
(define (get table key)
|
|
((table 'get) key))
|