define-namespace and SRFI-1

1 files changed, 91 insertions, 0 deletions

diff --git a/define-namespace-5.scm b/define-namespace-5.scm
new file mode 100644
index 0000000..0a9211c
--- /dev/null
+++ b/define-namespace-5.scm
@@ -0,0 +1,91 @@
+;;; Copyright (c) 2024, Peter McGoron
+;;; 
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 
+;;; 1) Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2) Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;; 
+
+;;; Compatability functions.
+;;; These functions abstract the namespace container. It is implemented
+;;; as assocation lists, but by changing these functions it could be a
+;;; hash table, binary tree, etc.
+
+(define (%namespace-new) (cons '() '()))
+(define (%namespace-set! ns id val)
+  (let ((alist (car ns)))
+    (set-car! ns (cons (cons id val) alist)))) 
+(define (%namespace-get ns id)
+  (let ((alist (car ns)))
+    (cdr (assv id alist))))
+
+;;; Internal definitions.
+
+(define-syntax %import-from-namespace
+  (syntax-rules (rename only)
+    ((%import-from-namespace continue (only ns identifier rest-only ...) rest ...)
+     (begin
+       (define identifier (%namespace-get ns (quote identifier)))
+       (%import-from-namespace continue (only ns rest-only ...) rest ...)))
+    ((%import-from-namespace continue (only ns) rest ...)
+     (%import-from-namespace continue rest ...))
+    ((%import-from-namespace continue (rename ns (inside to) rename-rest ...) rest ...)
+     (begin
+       (define to (%namespace-get ns (quote inside)))
+       (%import-from-namespace continue (rename ns rename-rest ...) rest ...)))
+    ((%import-from-namespace continue (rename ns) rest ...)
+     (%import-from-namespace continue rest ...))
+    ((%import-from-namespace continue) continue)))
+
+(define-syntax %define-namespace
+  (syntax-rules (export import begin)
+    ((%define-namespace name (begin decls ...) rest ...)
+     (begin
+       (begin decls ...)
+       (%define-namespace name rest ...)))
+    ((%define-namespace name (export identifier exportspec ...) rest ...)
+     (begin
+       (%namespace-set! name (quote identifier) identifier)
+       (%define-namespace name (export exportspec ...) rest ...)))
+    ((%define-namespace name (export) rest ...)
+     (%define-namespace name rest ...))
+    ((%define-namespace name (import body ...) rest ...)
+     (%import-from-namespace (%define-namespace name rest ...)
+                             body ...))
+    ((%define-namespace name) '())))
+
+;;; External definitions.
+
+(define-syntax define-namespace
+  (syntax-rules ()
+    ((define-namespace name body ...)
+     (begin
+       (define name (%namespace-new))
+       (let ((dummy-variable '()))
+         (%define-namespace name body ...))))))
+
+(define-syntax import-from-namespace
+  (syntax-rules ()
+    ((import-from-namespace body ...)
+     (%import-from-namespace '() body ...))))
+
+(import-from-namespace (only srfi-1 fold))
+(fold (lambda (elem acc) (+ elem acc)) 0'(1 2 3 4 5))
+