add subtyping back

1 files changed, 116 insertions, 50 deletions

diff --git a/lib/SAHP/internal-common.scm b/lib/SAHP/internal-common.scm
index 5854c51..c40be51 100644
--- a/lib/SAHP/internal-common.scm
+++ b/lib/SAHP/internal-common.scm
@@ -14,33 +14,37 @@
  | 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
+;;; 
+;;; 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)
+  (eq? (SAHP-entry-flag entry) 'overridable))
+
 (define (SAHP=? sahp1 sahp2)
   (eq? (SAHP-global-scope (extract-SAHP-descriptor sahp1))
        (SAHP-global-scope (extract-SAHP-descriptor sahp2))))
@@ -49,32 +53,26 @@
 ;;; 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-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)
@@ -91,15 +89,83 @@
   (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 (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)
-  (apply (lookup-SAHP-implementation 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))))