add subtyping back

1 files changed, 48 insertions, 16 deletions

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)