blob: 4e39cbe3b7545ad7e98b12e1bda934012e1d0607 (
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
|
;;; From 6.945 Staff, with minor edit by bnewbold (May 2009)
;;;; 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 ASSIGN-OPERATION).
;;; 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 by OR.
(define (make-generic-operator arity default-operation #!optional name)
(let ((record (make-operator-record arity)))
(define (operator . arguments)
(if (not (= (length arguments) arity))
(error:wrong-number-of-arguments operator arity arguments))
(let ((succeed
(lambda (handler)
(apply handler arguments))))
(let per-arg
((tree (operator-record-tree record))
(args arguments)
(fail
(lambda ()
(error:no-applicable-methods operator arguments))))
(let per-pred ((tree tree) (fail fail))
(cond ((pair? tree)
(if ((caar tree) (car args))
(if (pair? (cdr args))
(per-arg (cdar tree)
(cdr args)
(lambda ()
(per-pred (cdr tree) fail)))
(succeed (cdar tree)))
(per-pred (cdr tree) fail)))
((null? tree)
(fail))
(else
(succeed tree)))))))
(hash-table/put! *generic-operator-table* operator record)
(if default-operation
(assign-operation operator default-operation))
(if (not (default-object? name))
(hash-table/put! *generic-operator-table* name record))
operator))
(define *generic-operator-table*
(make-eq-hash-table))
(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 (assign-operation operator handler . argument-predicates)
(let ((record
(let ((record (hash-table/get *generic-operator-table* operator #f))
(arity (length argument-predicates)))
(if record
(begin
(if (not (<= arity (operator-record-arity record)))
(error "Incorrect operator arity:" operator))
record)
(let ((record (make-operator-record arity)))
(hash-table/put! *generic-operator-table* operator record)
record)))))
(set-operator-record-tree! record
(bind-in-tree argument-predicates
handler
(operator-record-tree record))))
operator)
(define defhandler assign-operation)
(define (bind-in-tree keys handler tree)
(let loop ((keys keys) (tree tree))
(if (pair? keys)
(let find-key ((tree* tree))
(if (pair? tree*)
(if (eq? (caar tree*) (car keys))
(begin
(set-cdr! (car tree*)
(loop (cdr keys) (cdar tree*)))
tree)
(find-key (cdr tree*)))
(cons (cons (car keys)
(loop (cdr keys) '()))
tree)))
(if (pair? tree)
(let ((p (last-pair tree)))
(if (not (null? (cdr p)))
(warn "Replacing a handler:" (cdr p) handler))
(set-cdr! p handler)
tree)
(begin
(if (not (null? tree))
(warn "Replacing top-level handler:" tree handler))
handler)))))
|
