-
Notifications
You must be signed in to change notification settings - Fork 1
/
ghelper.scm
194 lines (168 loc) · 6.62 KB
/
ghelper.scm
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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
;;;; Most General Generic-Operator Dispatch
(declare (usual-integrations))
;;; Generic-operator dispatch is implemented here by a discrimination
;;; list, where the arguments passed to the operator are examined by
;;; predicates that are supplied at the point of attachment of a
;;; handler (by DEFHANDLER).
;;; To be the correct branch all arguments must be accepted by the
;;; branch predicates, so this makes it necessary to backtrack to find
;;; another branch where the first argument is accepted if the second
;;; argument is rejected. Here backtracking is implemented using #f
;;; as a failure return, requiring further search. A success is
;;; consummated by calling the WIN procedure.
;;; The discrimination list has the following structure: it is a
;;; possibly improper alist whose "keys" are the predicates that are
;;; applicable to the first argument. If a predicate matches the
;;; first argument, the cdr of that alist entry is a discrimination
;;; list for handling the rest of the arguments. If a discrimination
;;; list is improper, then the cdr at the end of the backbone of the
;;; alist is the default handler to apply (all remaining arguments are
;;; implicitly accepted).
(define (make-generic-operator arity #!optional name default-operation)
(let ((record (make-operator-record arity)))
(define (find-branch tree arg win)
(let loop ((tree tree))
(cond ((pair? tree)
(or (and ((caar tree) arg)
(win (cdar tree)))
(loop (cdr tree))))
((null? tree) #f)
(else tree))))
(define (find-handler arguments)
(let loop ((tree (operator-record-tree record))
(args arguments))
(find-branch tree (car args)
(if (pair? (cdr args))
(lambda (branch) (loop branch (cdr args)))
identity))))
(define (operator . arguments)
(if (not (acceptable-arglist? arguments arity))
(error:wrong-number-of-arguments
(if (default-object? name) operator name) arity arguments))
(apply (find-handler arguments) arguments))
(set-operator-record! operator record)
(if (not (default-object? name))
(set-operator-record! name record))
(set! default-operation
(if (default-object? default-operation)
(named-lambda (no-handler . arguments)
(error "Generic operator inapplicable:"
(if (default-object? name) operator name)
arguments))
default-operation))
(assign-operation operator default-operation)
operator))
(define *generic-operator-table*
(make-eq-hash-table))
(define (get-operator-record operator)
(hash-table/get *generic-operator-table* operator #f))
(define (set-operator-record! operator record)
(hash-table/put! *generic-operator-table* operator record))
(define (make-operator-record arity) (cons arity '()))
(define (operator-record-arity record) (car record))
(define (operator-record-tree record) (cdr record))
(define (set-operator-record-tree! record tree) (set-cdr! record tree))
(define (acceptable-arglist? lst arity)
(let ((len (length lst)))
(and (fix:<= (procedure-arity-min arity) len)
(or (not (procedure-arity-max arity))
(fix:>= (procedure-arity-max arity) len)))))
(define (assign-operation operator handler . argument-predicates)
(let ((record (get-operator-record operator))
(arity (length argument-predicates)))
(if record
(begin
(if (not (<= arity (procedure-arity-min
(operator-record-arity record))))
(error "Incorrect operator arity:" operator))
(bind-in-tree
argument-predicates
handler
(operator-record-tree record)
(lambda (new)
(set-operator-record-tree! record new))))
(error "Assigning a handler to an undefined generic operator"
operator)))
operator)
(define defhandler assign-operation)
(define (bind-in-tree keys handler tree replace!)
(let loop ((keys keys) (tree tree) (replace! replace!))
(if (pair? keys)
;; There are argument predicates left
(let find-key ((tree* tree))
(if (pair? tree*)
(if (eq? (caar tree*) (car keys))
;; There is already some discrimination list keyed
;; by this predicate: adjust it according to the
;; remaining keys
(loop (cdr keys)
(cdar tree*)
(lambda (new)
(set-cdr! (car tree*) new)))
(find-key (cdr tree*)))
(let ((better-tree
(cons (cons (car keys) '()) tree)))
;; There was no entry for the key I was looking for.
;; Create it at the head of the alist and try again.
(replace! better-tree)
(loop keys better-tree replace!))))
;; Ran out of argument predicates
(if (pair? tree)
;; There is more discrimination list here, because my
;; predicate list is a proper prefix of the predicate list
;; of some previous assign-operation. Insert the handler
;; at the end, causing it to implicitly accept any
;; arguments that fail all available tests.
(let ((p (last-pair tree)))
(if (not (null? (cdr p)))
(warn "Replacing a default handler:" (cdr p) handler))
(set-cdr! p handler))
(begin
;; There is no discrimination list here, because my
;; predicate list is not the proper prefix of that of
;; any previous assign-operation. This handler becomes
;; the discrimination list, accepting further arguments
;; if any.
(if (not (null? tree))
(warn "Replacing a handler:" tree handler))
(replace! handler))))))
#|
;;; Demonstration of handler tree structure.
;;; Note: symbols were used instead of procedures
(define foo (make-generic-operator 3 'foo 'foo-default))
(pp (get-operator-record foo))
(3 . foo-default)
(defhandler foo 'two-arg-a-b 'a 'b)
(pp (get-operator-record foo))
(3 (a (b . two-arg-a-b)) . foo-default)
(defhandler foo 'two-arg-a-c 'a 'c)
(pp (get-operator-record foo))
(3 (a (c . two-arg-a-c) (b . two-arg-a-b)) . foo-default)
(defhandler foo 'two-arg-b-c 'b 'c)
(pp (get-operator-record foo))
(3 (b (c . two-arg-b-c))
(a (c . two-arg-a-c) (b . two-arg-a-b))
. foo-default)
(defhandler foo 'one-arg-b 'b)
(pp (get-operator-record foo))
(3 (b (c . two-arg-b-c) . one-arg-b)
(a (c . two-arg-a-c) (b . two-arg-a-b))
. foo-default)
(defhandler foo 'one-arg-a 'a)
(pp (get-operator-record foo))
(3 (b (c . two-arg-b-c) . one-arg-b)
(a (c . two-arg-a-c) (b . two-arg-a-b) . one-arg-a)
.
foo-default)
(defhandler foo 'one-arg-a-prime 'a)
;Warning: Replacing a default handler: one-arg-a one-arg-a-prime
(defhandler foo 'two-arg-a-b-prime 'a 'b)
;Warning: Replacing a handler: two-arg-a-b two-arg-a-b-prime
(defhandler foo 'three-arg-x-y-z 'x 'y 'z)
(pp (get-operator-record foo))
(3 (x (y (z . three-arg-x-y-z)))
(b (c . two-arg-b-c) . one-arg-b)
(a (c . two-arg-a-c) (b . two-arg-a-b-prime) . one-arg-a-prime)
.
foo-default)
|#