add subtyping back

5 files changed, 197 insertions, 90 deletions

diff --git a/lib/SAHP.scm b/lib/SAHP.scm
index 0e50b0a..1d17e45 100644
--- a/lib/SAHP.scm
+++ b/lib/SAHP.scm
@@ -1,4 +1,4 @@
-#| Copyright 2024 Peter McGoron
+#| Copyright 2025 Peter McGoron
  |
  | Licensed under the Apache License, Version 2.0 (the "License");
  |
@@ -18,13 +18,22 @@
 ;;; API
 ;;; ;;;;;;;;;;;;
 
-(define (set-global-SAHP! SAHP type procedure)
-  (%SAHP-add-to-global (extract-SAHP-descriptor SAHP)
-                       type
-                       procedure))
+(define set-global-SAHP!
+  (case-lambda
+    ((SAHP type procedure)
+     (set-global-SAHP! SAHP type #f procedure))
+    ((SAHP type flag procedure)
+     (%SAHP-set (SAHP-global-scope (extract-SAHP-descriptor SAHP))
+                (list (list type flag procedure))))))
 
 (define-syntax define-global-SAHP
   (syntax-rules ()
+    ((_ (name (type flag arg1) . arg-rest) body ...)
+     (set-global-SAHP! name
+                       type
+                       flag
+                       (lambda (arg1 . arg-rest)
+                         body ...)))
     ((_ (name (type arg1) . arg-rest) body ...)
      (set-global-SAHP! name
                        type
@@ -34,24 +43,27 @@
 (define-syntax parameterize-SAHP
   (syntax-rules ()
     ((_ ((SAHP (type value) ...) ...) body ...)
+     (parameterize-SAHP ((SAHP (type #f value) ...) ...) body ...))
+    ((_ ((SAHP (type flag value) ...) ...) body ...)
      (let ((param (SAHP-dynamic-scope-parameter (extract-SAHP-descriptor
                                                  SAHP)))
            ...)
-       (parameterize ((param (%SAHP-set/subtypes (param)
-                                                 (list type ...)
-                                                 (list value ...)))
+       (parameterize ((param (%SAHP-set (param)
+                                        (list (list type flag value)
+                                              ...)))
                       ...)
          body ...)))))
 
 (define-syntax letrec-SAHP
   (syntax-rules ()
     ((_ ((SAHP (type value) ...) ...) body ...)
+     (letrec-SAHP ((SAHP (type #f value) ...) ...) body ...))
+    ((_ ((SAHP (type flag value) ...) ...) body ...)
      (let ((%SAHP (extract-SAHP-descriptor SAHP)) ...)
        (letrec ((SAHP (%SAHP/local-scope
                        %SAHP
-                       (%SAHP-set/subtypes (SAHP-local-scope
-                                            %SAHP)
-                                           (list type ...)
-                                           (list value ...))))
+                       (%SAHP-set (SAHP-local-scope %SAHP)
+                                  (list (list type flag value)
+                                        ...))))
                 ...)
          body ...)))))
diff --git a/lib/SAHP.sld b/lib/SAHP.sld
index 5ab78a4..c8349ca 100644
--- a/lib/SAHP.sld
+++ b/lib/SAHP.sld
@@ -15,16 +15,15 @@
  |#
 
 (define-library (SAHP)
-  (import (scheme base)
+  (import (scheme base) (scheme case-lambda)
           (SAHP internal))
   (export make-new-SAHP SAHP=?
           set-global-SAHP! define-global-SAHP
           SAHP-implementation-not-found-error?
           parameterize-SAHP letrec-SAHP
-          all-exact-integers all-exact-rationals
-          all-reals all-complex all-numbers
           ;; Internal API exposed only for macro use
           SAHP-dynamic-scope-parameter
           SAHP-local-scope
-          %SAHP-set/subtypes %SAHP/local-scope)
+          %SAHP-set
+          %SAHP/local-scope)
   (include "SAHP.scm"))
diff --git a/lib/SAHP/internal-chicken.scm b/lib/SAHP/internal-chicken.scm
index e5392a2..3888630 100644
--- a/lib/SAHP/internal-chicken.scm
+++ b/lib/SAHP/internal-chicken.scm
@@ -1,3 +1,32 @@
+#| 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.
+ |#
+
+;;; ;;;;;;;;;;;;;;;;;;;;;
+;;; The value of the type field of a define-record-type declaration is an
+;;; *uninterned* symbol, which causes all sorts of chaos.
+;;; 
+;;; This implementation uses `eq?` with Chicken's `hash-by-identity` on
+;;; SRFI-146 hash mapping, specifically HAMT.
+
+(define persistent-type-table-comparator
+  (make-comparator symbol? eq? #f hash-by-identity))
+
+(define (make-persistent-type-table)
+  (hashmap persistent-type-table-comparator))
+
 (define (%make-derived-SAHP desc)
   (let ((proc (lambda (arg1 . arg-rest)
                 (call-SAHP desc (type-of arg1) (cons arg1 arg-rest)))))
@@ -5,9 +34,9 @@
 
 (define (make-new-SAHP)
   (%make-derived-SAHP
-   (make-SAHP-descriptor (make-symbol-mapping)
-                         (make-parameter (make-symbol-mapping))
-                         (make-hash-table))))
+   (make-SAHP-descriptor (make-persistent-type-table)
+                         (make-parameter (make-persistent-type-table))
+                         (make-hash-table eq? hash-by-identity))))
 
 (define (SAHP? x)
   (and (extended-procedure? x)
@@ -19,9 +48,9 @@
   (cond
     ((fixnum? x) 'fixnum)
     ((bignum? x) 'bignum)
-    ((flonum? x) 'flonum)
-    ((cplxnum? x) 'cplxnum)
     ((ratnum? x) 'ratnum)
+    ((cplxnum? x) 'cplxnum)
+    ((flonum? x) 'flonum)
     ((boolean? x) 'boolean)
     ((char? x) 'char)
     ((null? x) 'null)
@@ -36,17 +65,20 @@
     ((record-instance? x) (record-instance-type x))
     (else (error "cannot derive type of" x))))
 
-(define all-exact-integers
-  '(fixnum bignum))
-
-(define all-exact-rationals
-  `(,all-exact-integers ratnum))
-
-(define all-reals
-  `(,all-exact-rationals flonum))
+(define supertype-table (make-hash-table eq? hash-by-identity))
 
-(define all-complex
-  `(,all-reals cplxnum))
+(define (supertype-of type)
+  (hash-table-ref/default supertype-table type #f))
 
-(define all-numbers all-complex)
+(define (add-supertype! subtype supertype)
+  (hash-table-set! supertype-table subtype supertype))
 
+(add-supertype! 'fixnum 'exact-integer)
+(add-supertype! 'bignum 'exact-integer)
+(add-supertype! 'exact-integer 'exact-rational)
+(add-supertype! 'ratnum 'exact-rational)
+(add-supertype! 'flonum 'real)
+(add-supertype! 'exact-rational 'real)
+(add-supertype! 'cplxnum 'complex)
+(add-supertype! 'real 'complex)
+(add-supertype! 'complex 'number)
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))))
diff --git a/lib/SAHP/internal.sld b/lib/SAHP/internal.sld
index 4a40096..5d66a67 100644
--- a/lib/SAHP/internal.sld
+++ b/lib/SAHP/internal.sld
@@ -16,20 +16,18 @@
 
 (define-library (SAHP internal)
   (import (scheme base)
-          (chicken base)
-          (srfi 1) (srfi 69) (srfi 111) (srfi 128) (srfi 146))
+          (srfi 1) (srfi 26) (srfi 69) (srfi 128) (srfi 146 hash))
   (export make-new-SAHP extract-SAHP-descriptor
+          SAHP-global-scope
           SAHP-dynamic-scope-parameter
           SAHP-local-scope
           SAHP=?
           SAHP-implementation-not-found-error?
-          %SAHP-set/subtypes
-          %SAHP-add-to-global
-          %SAHP/local-scope
-          all-exact-integers all-exact-rationals
-          all-reals all-complex all-numbers)
+          %SAHP-set
+          %SAHP/local-scope)
   (cond-expand
-    (chicken (import (chicken memory representation))
+    (chicken (import (chicken base)
+                     (chicken memory representation))
              (include "internal-chicken.scm"))
     (else (include "internal-portable.scm")))
   (include "internal-common.scm"))