;;; 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 ...))))