blob: 603d4d78e6a396c86415a4be0c2c49ddd4f1c33d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
#lang racket
(provide
make-apply-with-coercion
make-apply
make-dispatch-table
printer
getter
putter
attach-tag
type-tag
contents
find-type)
(require "./lists.rkt")
(define (make-apply-with-coercion get get-coercion)
(lambda (op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags)))))))
;; Type tagged data
(define (attach-tag type-tag contents)
(cond ((number? contents) contents)
((symbol? contents) contents)
(else (cons type-tag contents))))
(define (type-tag datum)
(cond
((pair? datum) (car datum))
((number? datum) 'scheme-number)
((symbol? datum) 'symbol)
(else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
(cond
((pair? datum) (cdr datum))
((number? datum) datum)
((symbol? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (find-type type seq)
(define (rec items)
(cond ((null? items) false)
((equal? type (type-tag (car items))) (car items))
(else (rec (cdr items)))))
(rec seq))
;; dispatch table abstraction barrier/ encapsulation
;; ('op (list ('(types) item)))
(define (make-dispatch-table)
(define dispatch-table '())
(define (printer)
(newline)
(println dispatch-table))
(define (get op types)
(let ((op-datum (find-type op dispatch-table)))
(if op-datum
(let ((proc-datum (find-type types (contents op-datum))))
(if (pair? proc-datum)
(contents proc-datum)
false))
false)))
(define (update-op-datum op-datum types proc)
(attach-tag (type-tag op-datum)
(if (find-type types (contents op-datum))
(map (lambda (proc-datum)
(if (not (eq? (type-tag proc-datum) types))
proc-datum
(attach-tag (type-tag proc-datum) proc)))
(contents op-datum))
(cons (attach-tag types proc) (contents op-datum)))))
(define (put op types item)
(if (find-type op dispatch-table)
(set! dispatch-table
(map (lambda (op-datum) ;;just copy the table for now, don't want to mutate yet
(if (not (equal? (type-tag op-datum) op))
op-datum
(update-op-datum op-datum types item)))
dispatch-table))
(set! dispatch-table (cons
(attach-tag op
(list (attach-tag types item)))
dispatch-table))))
(list dispatch-table get put printer))
(define (getter t)
(cadr t))
(define (putter t)
(caddr t))
(define (printer t)
(cadddr t))
(define (make-apply get)
(lambda (op . args)
(display args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags)))))))
|
