1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
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))
|
