88 lines
3.7 KiB
Scheme
88 lines
3.7 KiB
Scheme
|
;;; 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 ...))))
|