blob: 9030c7ce690c3738f31e8bb996cd14d025a2bdd5 (
plain) (
blame)
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
|
#| Copyright 2024 Peter McGoron
|
| Licensed under the Apache License, Version 2.0 (the "License");
|
| you may not use this file except in compliance with the License.
| You may obtain a copy of the License at
|
| http://www.apache.org/licenses/LICENSE-2.0
|
| Unless required by applicable law or agreed to in writing, software
| distributed under the License is distributed on an "AS IS" BASIS,
| WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
| See the License for the specific language governing permissions and
| limitations under the License.
|#
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define symbol-comparator
(make-comparator symbol?
symbol=?
(lambda (s1 s2)
(string<=? (symbol->string s1)
(symbol->string s2)))
(lambda (s)
(string-hash (symbol->string s)))))
(define (make-symbol-mapping)
(mapping symbol-comparator))
;;; ;;;;;;;;;;;;;;;;;;;;
;;; Defining the SAHP object
;;; ;;;;;;;;;;;;;;;;;;;;
(define-record-type <SAHP-descriptor>
(make-SAHP-descriptor local-scope dynamic-scope global-scope)
SAHP-descriptor?
(local-scope SAHP-local-scope)
(dynamic-scope SAHP-dynamic-scope-parameter)
(global-scope SAHP-global-scope))
(define-record-type <SAHP-entry>
(make-SAHP-entry procedure inherited?)
SAHP-entry?
(procedure SAHP-entry-procedure)
(inherited? SAHP-entry-inherited?))
(define (SAHP=? sahp1 sahp2)
(eq? (SAHP-global-scope (extract-SAHP-descriptor sahp1))
(SAHP-global-scope (extract-SAHP-descriptor sahp2))))
;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Handling scope
;;; ;;;;;;;;;;;;;;;;;;;;;;
(define (add-to-scope/subtypes scope type value)
(define (entry-is-empty-or-inherited? scope type)
(mapping-ref scope type (lambda () #t) SAHP-entry-inherited?))
(define (recurse-on-subtype subtype scope)
(if (entry-is-empty-or-inherited? scope subtype)
(fold recurse-on-subtype
(mapping-set scope
subtype
(make-SAHP-entry value #t))
(subtypes subtype))
scope))
(fold recurse-on-subtype
(mapping-set scope
type
(make-SAHP-entry value #f))
(subtypes type)))
(define (%SAHP-add-to-global/subtypes SAHP-desc type value)
(define table (SAHP-global-scope SAHP-desc))
(define (empty-or-inherited? type)
(let ((entry (hash-table-ref/default table type #f)))
(if (SAHP-entry? entry)
(SAHP-entry-inherited? entry)
#t)))
(define (recurse-on-subtype type)
(when (empty-or-inherited? type)
(hash-table-set! table type (make-SAHP-entry value #t))
(for-each recurse-on-subtype (subtypes type))))
(hash-table-set! table type (make-SAHP-entry value #f))
(for-each recurse-on-subtype (subtypes type)))
(define (%SAHP-set/subtypes scope types values)
(cond
((null? types) scope)
(else (%SAHP-set/subtypes (add-to-scope/subtypes
scope
(car types)
(car values))
(cdr types)
(cdr values)))))
(define (%SAHP/local-scope SAHP local-scope)
(%make-derived-SAHP
(make-SAHP-descriptor local-scope
(SAHP-dynamic-scope-parameter SAHP)
(SAHP-global-scope SAHP))))
;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Lookup
;;; ;;;;;;;;;;;;;;;;;;;;;;
(define cannot-find-implementation-str
"cannot find implementation")
(define (SAHP-implementation-not-found-error? x)
(and (error-object? x)
(eq? (error-object-message x) cannot-find-implementation-str)))
(define (lookup-SAHP-implementation desc type)
(or (mapping-ref/default (SAHP-local-scope desc) type #f)
(mapping-ref/default ((SAHP-dynamic-scope-parameter desc)) type #f)
(hash-table-ref/default (SAHP-global-scope desc) type #f)
(error cannot-find-implementation-str desc type)))
(define (call-SAHP desc type arguments)
(apply (SAHP-entry-procedure (lookup-SAHP-implementation desc type))
arguments))
|
