blob: c6a7f8561ffa427807fd3d38de1d0a1b71a2f522 (
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
|
;;;; 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)
(let ((record (make-operator-record arity)))
(define (operator . arguments)
(if (not (= (length arguments) arity))
(error:wrong-number-of-arguments operator arity arguments))
(apply (or (let per-arg
((tree (operator-record-tree record))
(args arguments))
(let per-pred ((tree tree))
(and (pair? tree)
(if ((caar tree) (car args))
(if (pair? (cdr args))
(or (per-arg (cdar tree) (cdr args))
(per-pred (cdr tree)))
(cdar tree))
(per-pred (cdr tree))))))
default-operation
(error:no-applicable-methods operator arguments))
arguments))
(hash-table/put! *generic-operator-table* operator 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 (bind-in-tree keys handler tree)
(let loop ((keys keys) (tree tree))
(let ((p.v (assq (car keys) tree)))
(if (pair? (cdr keys))
(if p.v
(begin
(set-cdr! p.v
(loop (cdr keys) (cdr p.v)))
tree)
(cons (cons (car keys)
(loop (cdr keys) '()))
tree))
(if p.v
(begin
(warn "Replacing a handler:" (cdr p.v) handler)
(set-cdr! p.v handler)
tree)
(cons (cons (car keys) handler)
tree))))))
|
