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
|
#| 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.
|#
;;; ;;;;;;;;;;;;;;;;;;;;
;;; Defining the SAHP object
;;;
;;; TODO: Memoization of inheritance from supertypes. Efficient versions of
;;; this would require
;;;
;;; * Inheriting all non-modified memoized values from modified scopes
;;; * Ephemeral tables for all scopes, not just global scope
;;; ;;;;;;;;;;;;;;;;;;;;
(define-record-type <SAHP-descriptor>
;; Holds the scopes of a SAHP.
(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>
;; An entry in the SAHP table.
;;
;; * `procedure`: Implemented procedure.
;; * `flag`: Flags passed to the entry after creation.
(make-SAHP-entry procedure flag)
SAHP-entry?
(procedure SAHP-entry-procedure)
(flag SAHP-entry-flag))
(define (entry-overridable? entry)
(member 'overridable (SAHP-entry-flag entry)))
(define (SAHP=? sahp1 sahp2)
(eq? (SAHP-global-scope (extract-SAHP-descriptor sahp1))
(SAHP-global-scope (extract-SAHP-descriptor sahp2))))
;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Handling scope
;;; ;;;;;;;;;;;;;;;;;;;;;;
(define (%SAHP-add-to-scope scope type flag value)
;; Add `value` for `type` with `flag` to `scope`, which can be persistent
;; or ephemeral.
(let ((entry (make-SAHP-entry value flag))
(proc (if (hash-table? scope)
hash-table-set!
hashmap-set)))
(proc scope type entry)))
(define (%SAHP-set scope arguments)
;; `arguments` is a list of triples `(list type flag value)`, which
;; are passed to `%SAHP-add-to-scope` with `scope` for each entry.
(fold (lambda (arglist scope)
(apply %SAHP-add-to-scope scope arglist))
scope
arguments))
(define (%SAHP/local-scope SAHP local-scope)
;; Create a SAHP with a shared dynamic and global scope, but with a
;; different 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-in-scope scope type)
;; Generic lookup in persistent or ephemeral table.
(let ((proc (if (hash-table? scope)
hash-table-ref/default
hashmap-ref/default)))
(proc scope type #f)))
;;; Algorithm to resolve values in scopes.
;;;
;;; Start with local scope as the current scope. Start with nothing as
;;; the "presumed" implementation.
;;;
;;; 1. If there are no more scopes to check, return the presumped
;;; implementation.
;;; 2. If the current scope has a specific implementation for the passed
;;; type, return it.
;;; 3. If the current scope has a implementation from a supertype that
;;; is not overridable, return it.
;;; 4. If the current scope has an implementation from a supertype that
;;; is overridable, then check if this implementatoin is more specific
;;; than the "presumed" implementation. If so, this implementation
;;; becomes the new presumed implementation. Continue on to the next
;;; scope at step 1.
;;; 5. If there is no suitable implementation, continue on to the next
;;; scope at step 1 with the same presumed implementation.
(define (lookup-in-scope/supertypes scope type num)
;; When entrying this function, `num` should always be `0`.
;;
;; Look up an entry for `type` in `scope`. If a direct implementation
;; is found, return `(values entry num)`. Otherwise, each supertype
;; of `type` is inspected in turn, incrementing `num` each time. If
;; an entry is found, it will return `(values entry* num*)`, where
;; `entry*` is the entry for the supertype and `num*` is the amount of
;; supertypes passed.
;;
;; If all supertypes are exhausted, the default implementation is
;; given, if it exists. Its number is `+inf.0`.
;;
;; If no suitable entry is found, return `(values #f #f)`.
(cond
((not type)
(cond
((lookup-in-scope scope '*) => (cut values <> +inf.0))
(else (values #f #f))))
((lookup-in-scope scope type) => (cut values <> num))
(else (lookup-in-scope/supertypes scope (supertype-of type)
(+ num 1)))))
(define (list-of-scopes desc)
;; Returns the list of scopes in `desc`.
(list (SAHP-local-scope desc)
((SAHP-dynamic-scope-parameter desc))
(SAHP-global-scope desc)))
(define (check-all-scopes desc type)
(let loop ((scopes (list-of-scopes desc))
(last-entry #f)
(last-distance #f))
(if (null? scopes)
last-entry
(let-values (((entry distance)
(lookup-in-scope/supertypes (car scopes)
type
0)))
(cond
((not entry) (loop (cdr scopes) last-entry last-distance))
((= distance 0) entry)
((or (not last-distance) (< distance last-distance))
;; Return more specific entry if not overridable
(if (entry-overridable? entry)
(loop (cdr scopes) entry distance)
entry))
(else (loop (cdr scopes) last-entry last-distance)))))))
(define (call-SAHP desc type arguments)
(let ((entry (check-all-scopes desc type)))
(if (not entry)
(error cannot-find-implementation-str type arguments)
(apply (SAHP-entry-procedure entry) arguments))))
|
