make library hierarchy again

4 files changed, 238 insertions, 0 deletions

diff --git a/lib/SAHP/SAHP.internal-chicken.scm b/lib/SAHP/SAHP.internal-chicken.scm
new file mode 100644
index 0000000..992d98f
--- /dev/null
+++ b/lib/SAHP/SAHP.internal-chicken.scm
@@ -0,0 +1,47 @@
+(define (%make-derived-SAHP desc)
+  (let ((proc (lambda (arg1 . arg-rest)
+                (call-SAHP desc (type-of arg1) (cons arg1 arg-rest)))))
+    (extend-procedure proc desc)))
+
+(define (make-new-SAHP)
+  (%make-derived-SAHP
+   (make-SAHP-descriptor (make-symbol-mapping)
+                         (make-parameter (make-symbol-mapping))
+                         (make-hash-table))))
+
+(define (SAHP? x)
+  (and (extended-procedure? x)
+       (SAHP-descriptor? (extract-SAHP-descriptor x))))
+
+(define extract-SAHP-descriptor procedure-data)
+
+(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)
+    ((boolean? x) 'boolean)
+    ((char? x) 'char)
+    ((null? x) 'null)
+    ((pair? x) 'pair)
+    ((procedure? x) 'procedure)
+    ((symbol? x) 'symbol)
+    ((bytevector? x) 'bytevector)
+    ((eof-object? x) 'eof-object)
+    ((port? x) 'port)
+    ((string? x) 'string)
+    ((vector? x) 'vector)
+    ((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 '())))
diff --git a/lib/SAHP/SAHP.internal-common.scm b/lib/SAHP/SAHP.internal-common.scm
new file mode 100644
index 0000000..9030c7c
--- /dev/null
+++ b/lib/SAHP/SAHP.internal-common.scm
@@ -0,0 +1,125 @@
+#| Copyright 2024 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.
+ |#
+
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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
+;;; ;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type <SAHP-descriptor>
+  (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>
+  (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))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+;;; 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 (%SAHP-set/subtypes scope types values)
+  (cond
+    ((null? types) scope)
+    (else (%SAHP-set/subtypes (add-to-scope/subtypes
+                               scope
+                               (car types)
+                               (car values))
+                              (cdr types)
+                              (cdr values)))))
+
+(define (%SAHP/local-scope SAHP local-scope)
+  (%make-derived-SAHP
+   (make-SAHP-descriptor local-scope
+                         (SAHP-dynamic-scope-parameter SAHP)
+                         (SAHP-global-scope SAHP))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+;;; Lookup
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+
+(define cannot-find-implementation-str
+  "cannot find implementation")
+
+(define (SAHP-implementation-not-found-error? x)
+  (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)
+      (error cannot-find-implementation-str desc type)))
+
+(define (call-SAHP desc type arguments)
+  (apply (SAHP-entry-procedure (lookup-SAHP-implementation desc type))
+         arguments))
diff --git a/lib/SAHP/SAHP.internal-portable.scm b/lib/SAHP/SAHP.internal-portable.scm
new file mode 100644
index 0000000..3174f4c
--- /dev/null
+++ b/lib/SAHP/SAHP.internal-portable.scm
@@ -0,0 +1,34 @@
+#| Copyright 2024 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.
+ |#
+
+#| A portable implementation of `extract-SAHP-descriptor`, `make-new-SAHP`
+   using a unexported sentinel object.
+|#
+
+(define SAHP-sentinel-value
+  (vector #f))
+
+(define (extract-SAHP-descriptor SAHP)
+  (SAHP SAHP-sentinel-value))
+
+(define (make-new-SAHP)
+  (let ((SAHP (make-SAHP-descriptor (make-symbol-mapping)
+                                    (make-parameter (make-symbol-mapping))
+                                    (make-symbol-hash-table)))))
+  (lambda (arg1 . arg-rest)
+    (if (eq? arg1 SAHP-sentinel-value)
+        SAHP
+        (call-SAHP SAHP (type-of arg1) (cons arg1 arg-rest)))))
diff --git a/lib/SAHP/SAHP.internal.sld b/lib/SAHP/SAHP.internal.sld
new file mode 100644
index 0000000..199a66a
--- /dev/null
+++ b/lib/SAHP/SAHP.internal.sld
@@ -0,0 +1,32 @@
+#| Copyright 2024 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.
+ |#
+
+(define-library (SAHP internal)
+  (import (scheme base)
+          (srfi 1) (srfi 69) (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)
+  (cond-expand
+    (chicken (import (chicken memory representation))
+             (include "SAHP.internal-chicken.scm"))
+    (else (include "SAHP.internal-portable.scm")))
+  (include "SAHP.internal-common.scm"))