blob: 5854c512124311c3340123bd4799ec7821c204e7 (
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
|
#| Copyright 2025 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 (SAHP=? sahp1 sahp2)
(eq? (SAHP-global-scope (extract-SAHP-descriptor sahp1))
(SAHP-global-scope (extract-SAHP-descriptor sahp2))))
;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Handling scope
;;; ;;;;;;;;;;;;;;;;;;;;;;
(define (add-to-scope scope type-expr value)
(cond
((pair? type-expr)
(fold (lambda (type-expr scope)
(add-to-scope scope type-expr value))
scope
type-expr))
(else (mapping-set scope type-expr value))))
(define (%SAHP-add-to-global SAHP-desc type-expr value)
(cond
((pair? type-expr)
(for-each (cut %SAHP-add-to-global SAHP-desc <> value)
type-expr))
(else (hash-table-set! (SAHP-global-scope SAHP-desc)
type-expr
value))))
(define (%SAHP-set/subtypes scope types values)
(cond
((null? types) scope)
(else (%SAHP-set/subtypes (add-to-scope 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)
(mapping-ref/default (SAHP-local-scope desc) '* #f)
(mapping-ref/default ((SAHP-dynamic-scope-parameter desc)) '* #f)
(hash-table-ref/default (SAHP-global-scope desc) '* #f)
(error cannot-find-implementation-str desc type)))
(define (call-SAHP desc type arguments)
(apply (lookup-SAHP-implementation desc type) arguments))
|
