add subtyping back

7 files changed, 333 insertions, 165 deletions

diff --git a/README.md b/README.md
index 449fd00..451e52a 100644
--- a/README.md
+++ b/README.md
@@ -20,13 +20,14 @@ surprises.
 
 ### Why Singly Polymorphic (aka Single Dispatch)?
 
-Multiple dispatch runs into the problems that subtype inheritance runs
-into (see the section "On Inheritance").
+Multiple dispatch runs into problems similar to that of multiple
+inheritance, except that there is no obvious dismabiguation pattern when
+two equally specific multiple dispatch methods exist.
 
-If one wanted multiple dispatch or multiple inheritance, it would be better
-to use a CLOS style system, which has much more fine-grained control over
-method dispatch. Dynamic and local scoping could be added to a CLOS style
-system, although the API would probably have to change.
+If one wanted multiple dispatch or multiple inheritance, it would be
+better to use a CLOS style system, which has much more fine-grained
+control over method dispatch. Dynamic and local scoping could be added
+to a CLOS style system, although the API would probably have to change.
 
 ### Why Scope?
 
@@ -52,11 +53,15 @@ without mutating global state and without overriding local scope.
 
 ### On Inheritance
 
-I am very conflicted on inheritance for subtypes of a type. The issue
-is that combining it with scoping introduces a form of the diamond
-problem. For example: imagine if type `T` has an implementation in global
-scope, and its supertype `T'` has an implementation in local scope. Which
-one should be used?
+Scheme, both through the numeric tower (see below) and R6RS, have single
+inheritance. I do not like inheritance: Rust (which inspired me to write
+this) does not have inheritance at all.
+
+Combining subtype inheritance (even when restricted to single inheritance)
+with scoping introduces a form of the diamond problem. For example:
+imagine if type `T` has an implementation in global scope, and its
+supertype `T'` has an implementation in local scope. Which one should
+be used?
 
                      SAHP 
                     /    \
@@ -66,15 +71,9 @@ one should be used?
                      \ /
                       T
 
-There are two reasonable choices: most specific and closest scope. Closest
-scope is probably the best option, but in some instances it may not
-be enough. One might want to specify a default implementation without
-desiring to override all specific implementations of subtypes. This could
-be done by giving one the ability to specify how each implementation
-should be inherited.
-
-SAHPs currently do not automatically inherit implementations. Records
-designed with SAHPs in mind should use composition, not inheritance.
+SAHPs default to selecting the closest scope. However, an implementation
+for a type may be labeled `overridable`, in which case if a more specific
+type occurs in a higher scope, that implementation is selected.
 
 ### The Numeric Tower
 
@@ -94,50 +93,44 @@ defined. They will usually consist of
 * irrationals,
 * proper complex numbers.
 
-An implementation could also have unitful numbers, quarternions, etc.
-
-In order to support the numeric tower, SAHPs define portable sets of
-types arranged in a hierarchy of subsets. They are
-
-    all-exact-integers
-    ⊆ all-exact-rational
-      ⊆ all-real
-        ⊆ all-complex
-          ⊆ all-number
+Notably, exactness *is* decided by type (or more accurately, the machine
+representation).
 
-Type sets are lists that contain other type sets or concrete
-types. Defining an implementation against a type set explicitly
-defines the type set against all implementations, overriding previous
-implementations: hence the prefix `all`. These sets are static.
+SAHPs dispatch on the following hierarchy of types:
 
-### What Types are dispatched against?
+* `exact-integer`
+* `exact-rational`
+* `real`
+* `complex`
+* `number`
 
-All fundamental types (pairs, fixnums, vectors, defined record types).
-Predicates are not dispatched against because that would make the type
-system inefficient. One could force this by putting predicates into the
-default implementation of a SAHP.
+This probably captures most practical uses of the numeric tower.
 
 ## API
 
 A SAHP is a procedure object. There is no portable way to differentiate
-between a SAHP and a regular procedure. A SAHP has multiple tables (some
-conceptual) where an implementation is looked up. In order, the SAHP will
+between a SAHP and a regular procedure. A SAHP has multiple tables
+(some conceptual) where an implementation is looked up. The SAHP will
 dispatch on (in order of precedence):
 
 * local scope
 * dynamic scope
 * global scope
-* default implementation in local scope
-* default implementation in dynamic scope
-* default implementation in global scope
 
-The scope resolution tries to find the most specific implementation, and
-given a specific implementation, the closest scope.
+The scope resolution tries to find the most specific implementation in
+the closest scope. If the implementation in closest scope is not the
+most specific implementation, then:
+
+* If the implementation in closest scope is labeled `overridable`, then
+  the implementation in the next closest scope is selected, and this
+  disambiguation process continues again.
+* If the implementation in closest scope is not labeled `overridable`,
+  then it is selected.
 
 The SAHP will raise an error object that satisfies the predicate
 `SAHP-implementation-not-found-error?` if no implementation is found.
 
-Multiple SAHPs can share global scope tables, and dynamic scope.
+Multiple SAHPs can share global scope tables and dynamic scope.
 
 The procedures stored in a SAHP must take at least one argument, which
 is the argument whose type is dispatched against.
@@ -150,13 +143,10 @@ it will call `procedure` with all of the arguments passed to it.
 
 A type expression is defined as:
 
-* The symbols `boolean`, `char`, `null`, `pair`, `procedure`, `symbol`,
-  `bytevector`, `eof-object`, `port`, `string`, or `vector`, or
-* The values of `all-exact-integers`, `all-exact-rationals`,
-  `all-real`, `all-complex`, and `all-number`, or
-* Lists of type expressions, or
+* The symbols `*` `boolean`, `char`, `null`, `pair`, `procedure`, `symbol`,
+  `bytevector`, `eof-object`, `port`, `string`, `vector`,
+  `exact-integers`, `exact-rationals`, `reals`, `complex`, or `numbers`, or
 * the value bound to a name of a record type, or
-* the symbol `*`, for the default implementation
 * any other implementation defined value.
 
 ### The Object
@@ -173,33 +163,50 @@ dynamic state. SAHPs that are `SAHP=?` are not necessarily `eqv?`.
 
 ### Global Scope
 
-    (set-global-SAHP! SAHP type-expr procedure procedure)
+    (set-global-SAHP! SAHP type procedure)
+
+or
+
+    (set-global-SAHP! SAHP type flag procedure)
+
+The flag can be omitted, or the symbol `overridable`.
 
-Set `SAHP` to resolve to `procedure` given `type-expr` in global scope.
+Set `SAHP` to resolve to `procedure` given `type` in global scope.
 
-    (define-global-SAHP (name (type-expr argument) . arg-rest) body ...)
+    (define-global-SAHP (name (type argument) . arg-rest) body ...)
+
+or
+
+    (define-global-SAHP (name (type flag argument) . arg-rest) body ...)
 
 Creates a procedure with the given arguments and body. The SAHP will
-resolve to this procedure given `type-expr` in global scope.
+resolve to this procedure given `type` in global scope.
+
+The flag can be omitted, or the symbol `overridable`.
 
 ### Dynamic Scope
 
-    (parameterize-SAHP ((SAHP (type-expr value) ...) ...) body ...)
+    (parameterize-SAHP ((SAHP (type value) ...) ...) body ...)
+
+or
+
+    (parameterize-SAHP ((SAHP (type flag value) ...) ...) body ...)
 
 Each `SAHP` must resolve to an SAHP.
 
-Each SAHP will have each `type-expr` under it resolve to `value`
-in dynamic scope. These procedures take precedence over global scope
-procedures.  The SAHPs are the same SAHP in the block in the sense of
-`eq?`.
+Each SAHP will have each `type` under it resolve to `value` in dynamic
+scope. These procedures take precedence over global scope procedures.
+The SAHPs are the same SAHP in the block in the sense of `eq?`.
+
+The flag can be omitted, or the symbol `overridable`.
 
 ### Local Scope
 
-    (letrec-SAHP ((SAHP (type-expr value) ...) ...) body ...)
+    (letrec-SAHP ((SAHP (type type value) ...) ...) body ...)
 
 Each `SAHP` must be an identifier that resolves to a SAHP.
 
-Each SAHP will have each `type-expr` under it resolve to the corresponding
+Each SAHP will have each `type` under it resolve to the corresponding
 `value` in lexical scope. Each procedure will have the new SAHPs in
 scope.  These procedures will take precedence over dynamic and global
 scope procedures.
@@ -213,6 +220,10 @@ If the SAHPs passed to `letrec-SAHP` had local bindings, then
 `letrec-SAHP` will replace old bindings and add new ones without affecting
 the previous SAHP object.
 
+The flag can be omitted, or the symbol `overridable`.
+
 ## TODO
 
 * Standard SAHP library.
+* `if-not-exists` to provide default implementations for specific
+  types.
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"))
diff --git a/tests/run.scm b/tests/run.scm
index cbc19f4..7ff4a6c 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -135,7 +135,7 @@
               (else #f)))))
       (test-property override (list (bytevector-generator))))))
 
-(test-group "numeric tower type expressions"
+(test-group "numeric tower subtyping"
   (define sub (make-new-SAHP))
   (define test-all-numbers
     (case-lambda
@@ -165,21 +165,36 @@
                       (sub +inf.0))))))
   (test-group "local scope"
     (test-group "type expression flow downwards"
-      (letrec-SAHP ((sub (all-numbers (lambda (x) #t))))
+      (letrec-SAHP ((sub ('number (lambda (x) #t))))
         (test-all-numbers sub)))
     (test-group "subtypes do not flow upwards"
-      (letrec-SAHP ((sub (all-exact-rationals (lambda (x) #t))))
+      (letrec-SAHP ((sub ('exact-rational (lambda (x) #t))))
         (test-some-numbers sub))))
   (test-group "dynamic scope"
     (test-group "subtypes flow downwards"
-      (parameterize-SAHP ((sub (all-numbers (lambda (x) #t))))
+      (parameterize-SAHP ((sub ('number (lambda (x) #t))))
         (test-all-numbers sub)))
     (test-group "subtypes do not flow upwards"
-      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) #t))))
+      (parameterize-SAHP ((sub ('exact-rational (lambda (x) #t))))
         (test-some-numbers sub)))
     (test-group "local scope overrides dynamic scope subtyping"
-      (parameterize-SAHP ((sub (all-numbers (lambda (x) 1))))
-        (letrec-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
+      (parameterize-SAHP ((sub ('number (lambda (x) 1))))
+        (letrec-SAHP ((sub ('exact-rational (lambda (x) 2))))
+          (define (test-local n)
+            (= 2 (sub n)))
+          (define (test-dynamic n)
+            (= 1 (sub n)))
+          (test-group "local"
+            (test-property test-local
+                           (list
+                            (gsampling (exact-rational-generator)))))
+          (test-group "dynamic"
+            (test-property test-dynamic
+                           (list
+                            (gsampling (inexact-complex-generator))))))))
+    (test-group "local scope overrides dynamic scope subtyping even with overridable"
+      (parameterize-SAHP ((sub ('number (lambda (x) 1))))
+        (letrec-SAHP ((sub ('exact-rational 'overridable (lambda (x) 2))))
           (define (test-local n)
             (= 2 (sub n)))
           (define (test-dynamic n)
@@ -193,7 +208,7 @@
                            (list
                             (gsampling (inexact-complex-generator)))))))))
   (test-group "global scope"
-    (define-global-SAHP (sub (all-numbers x))
+    (define-global-SAHP (sub ('number x))
       1)
     (define (test-global n)
       (= 1 (sub n)))
@@ -202,7 +217,17 @@
     (test-group "subtypes flow downwards"
       (test-all-numbers))
     (test-group "dynamic scope overrides global scope"
-      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
+      (parameterize-SAHP ((sub ('exact-rational (lambda (x) 2))))
+        (test-group "dynamic"
+          (test-property test-dynamic
+                         (list
+                          (gsampling (exact-rational-generator)))))
+        (test-group "global"
+          (test-property test-global
+                         (list
+                          (gsampling (inexact-complex-generator)))))))
+    (test-group "dynamic scope overrides global scope even with overridable"
+      (parameterize-SAHP ((sub ('exact-rational 'overridable (lambda (x) 2))))
         (test-group "dynamic"
           (test-property test-dynamic
                          (list
@@ -212,8 +237,31 @@
                          (list
                           (gsampling (inexact-complex-generator)))))))
     (test-group "local scope overrides dynamic scope overrides global scope"
-      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
-        (letrec-SAHP ((sub (all-exact-integers (lambda (x) 3))))
+      (parameterize-SAHP ((sub ('exact-rational (lambda (x) 2))))
+        (letrec-SAHP ((sub ('exact-integer (lambda (x) 3))))
+          (define (test-local n)
+            (= 3 (sub n)))
+          (test-group "dynamic"
+            (test-property test-dynamic
+                           (list
+                            (gsampling (exact-rational-generator)))))
+          (test-group "global"
+            (test-property test-global
+                           (list
+                            (gsampling (inexact-complex-generator)))))
+          (test-group "local"
+            (test-property test-local
+                           (list
+                            (gsampling (exact-integer-generator))))))))
+    (test-group "local scope overrides dynamic scope overrides global scope even when overridable"
+      (parameterize-SAHP ((sub
+                           ('exact-rational
+                            'overridable
+                            (lambda (x) 2))))
+        (letrec-SAHP ((sub
+                       ('exact-integer
+                        'overridable
+                        (lambda (x) 3))))
           (define (test-local n)
             (= 3 (sub n)))
           (test-group "dynamic"
@@ -228,3 +276,5 @@
             (test-property test-local
                            (list
                             (gsampling (exact-integer-generator))))))))))
+
+;;; TODO: tests of override