make library hierarchy again

4 files changed, 0 insertions, 238 deletions

diff --git a/SAHP/SAHP.internal-chicken.scm b/SAHP/SAHP.internal-chicken.scm
deleted file mode 100644
index 992d98f..0000000
--- a/SAHP/SAHP.internal-chicken.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-(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/SAHP/SAHP.internal-common.scm b/SAHP/SAHP.internal-common.scm
deleted file mode 100644
index 9030c7c..0000000
--- a/SAHP/SAHP.internal-common.scm
+++ /dev/null
@@ -1,125 +0,0 @@
-#| 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/SAHP/SAHP.internal-portable.scm b/SAHP/SAHP.internal-portable.scm
deleted file mode 100644
index 3174f4c..0000000
--- a/SAHP/SAHP.internal-portable.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-#| 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/SAHP/SAHP.internal.sld b/SAHP/SAHP.internal.sld
deleted file mode 100644
index 199a66a..0000000
--- a/SAHP/SAHP.internal.sld
+++ /dev/null
@@ -1,32 +0,0 @@
-#| 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"))