reorganize to remove subtype inheritance

5 files changed, 54 insertions, 64 deletions

diff --git a/lib/SAHP.scm b/lib/SAHP.scm
index 3e60956..0e50b0a 100644
--- a/lib/SAHP.scm
+++ b/lib/SAHP.scm
@@ -19,9 +19,9 @@
 ;;; ;;;;;;;;;;;;
 
 (define (set-global-SAHP! SAHP type procedure)
-  (%SAHP-add-to-global/subtypes (extract-SAHP-descriptor SAHP)
-                                type
-                                procedure))
+  (%SAHP-add-to-global (extract-SAHP-descriptor SAHP)
+                       type
+                       procedure))
 
 (define-syntax define-global-SAHP
   (syntax-rules ()
diff --git a/lib/SAHP.sld b/lib/SAHP.sld
index 49d5cb2..5ab78a4 100644
--- a/lib/SAHP.sld
+++ b/lib/SAHP.sld
@@ -21,6 +21,8 @@
           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
diff --git a/lib/SAHP/internal-chicken.scm b/lib/SAHP/internal-chicken.scm
index 992d98f..e5392a2 100644
--- a/lib/SAHP/internal-chicken.scm
+++ b/lib/SAHP/internal-chicken.scm
@@ -17,12 +17,11 @@
 
 (define (type-of x)
   (cond
-    ((exact-integer? x) 'exact-integer)
-    ((integer? x) 'integer)
-    ((rational? x) 'rational)
-    ((real? x) 'real)
-    ((complex? x) 'complex)
-    ((number? x) 'number)
+    ((fixnum? x) 'fixnum)
+    ((bignum? x) 'bignum)
+    ((flonum? x) 'flonum)
+    ((cplxnum? x) 'cplxnum)
+    ((ratnum? x) 'ratnum)
     ((boolean? x) 'boolean)
     ((char? x) 'char)
     ((null? x) 'null)
@@ -37,11 +36,17 @@
     ((record-instance? x) (record-instance-type x))
     (else (error "cannot derive type of" x))))
 
-(define (subtypes type)
-  (case type
-    ((number) '(complex))
-    ((complex) '(real))
-    ((real) '(rational))
-    ((rational) '(integer))
-    ((integer) '(exact-integer))
-    (else '())))
+(define all-exact-integers
+  '(fixnum bignum))
+
+(define all-exact-rationals
+  `(,all-exact-integers ratnum))
+
+(define all-reals
+  `(,all-exact-rationals flonum))
+
+(define all-complex
+  `(,all-reals cplxnum))
+
+(define all-numbers all-complex)
+
diff --git a/lib/SAHP/internal-common.scm b/lib/SAHP/internal-common.scm
index 9030c7c..5854c51 100644
--- a/lib/SAHP/internal-common.scm
+++ b/lib/SAHP/internal-common.scm
@@ -1,4 +1,4 @@
-#| Copyright 2024 Peter McGoron
+#| Copyright 2025 Peter McGoron
  |
  | Licensed under the Apache License, Version 2.0 (the "License");
  |
@@ -14,7 +14,6 @@
  | limitations under the License.
  |#
 
-
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Utilities
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -42,12 +41,6 @@
   (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))))
@@ -56,44 +49,28 @@
 ;;; 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 (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/subtypes
-                               scope
-                               (car types)
-                               (car values))
+    (else (%SAHP-set/subtypes (add-to-scope scope (car types) (car values))
                               (cdr types)
                               (cdr values)))))
 
@@ -118,8 +95,11 @@
   (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 (SAHP-entry-procedure (lookup-SAHP-implementation desc type))
-         arguments))
+  (apply (lookup-SAHP-implementation desc type) arguments))
+
diff --git a/lib/SAHP/internal.sld b/lib/SAHP/internal.sld
index e4a5ac0..4a40096 100644
--- a/lib/SAHP/internal.sld
+++ b/lib/SAHP/internal.sld
@@ -16,15 +16,18 @@
 
 (define-library (SAHP internal)
   (import (scheme base)
-          (srfi 1) (srfi 69) (srfi 128) (srfi 146))
+          (chicken base)
+          (srfi 1) (srfi 69) (srfi 111) (srfi 128) (srfi 146))
   (export make-new-SAHP extract-SAHP-descriptor
           SAHP-dynamic-scope-parameter
           SAHP-local-scope
           SAHP=?
           SAHP-implementation-not-found-error?
           %SAHP-set/subtypes
-          %SAHP-add-to-global/subtypes
-          %SAHP/local-scope)
+          %SAHP-add-to-global
+          %SAHP/local-scope
+          all-exact-integers all-exact-rationals
+          all-reals all-complex all-numbers)
   (cond-expand
     (chicken (import (chicken memory representation))
              (include "internal-chicken.scm"))