Commit | Line | Data |
---|---|---|
b1e4c7cc JG |
1 | ;;; r6rs-libraries.scm --- Support for the R6RS `library' and `import' forms |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
4 | ;; | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | \f | |
19 | ||
20 | ;; This file is included from boot-9.scm and assumes the existence of (and | |
21 | ;; expands into) procedures and syntactic forms defined therein. | |
22 | ||
23 | (define (resolve-r6rs-interface import-spec) | |
24 | (define (make-custom-interface mod) | |
25 | (let ((iface (make-module))) | |
26 | (set-module-kind! iface 'custom-interface) | |
27 | (set-module-name! iface (module-name mod)) | |
28 | iface)) | |
29 | (define (sym? x) (symbol? (syntax->datum x))) | |
30 | ||
31 | (syntax-case import-spec (library only except prefix rename srfi) | |
b1e5445f | 32 | ;; (srfi :n ...) -> (srfi srfi-n) |
b1e4c7cc JG |
33 | ((library (srfi colon-n rest ... (version ...))) |
34 | (and (and-map sym? #'(srfi rest ...)) | |
35 | (symbol? (syntax->datum #'colon-n)) | |
36 | (eqv? (string-ref (symbol->string (syntax->datum #'colon-n)) 0) #\:)) | |
37 | (let ((srfi-n (string->symbol | |
38 | (string-append | |
39 | "srfi-" | |
40 | (substring (symbol->string (syntax->datum #'colon-n)) | |
41 | 1))))) | |
42 | (resolve-r6rs-interface | |
b1e5445f | 43 | #`(library (srfi #,srfi-n (version ...)))))) |
b1e4c7cc JG |
44 | |
45 | ((library (name name* ... (version ...))) | |
46 | (and-map sym? #'(name name* ...)) | |
47 | (resolve-interface (syntax->datum #'(name name* ...)) | |
48 | #:version (syntax->datum #'(version ...)))) | |
49 | ||
50 | ((library (name name* ...)) | |
51 | (and-map sym? #'(name name* ...)) | |
52 | (resolve-r6rs-interface #'(library (name name* ... ())))) | |
53 | ||
54 | ((only import-set identifier ...) | |
55 | (and-map sym? #'(identifier ...)) | |
56 | (let* ((mod (resolve-r6rs-interface #'import-set)) | |
57 | (iface (make-custom-interface mod))) | |
58 | (for-each (lambda (sym) | |
59 | (module-add! iface sym | |
60 | (or (module-local-variable mod sym) | |
61 | (error "no binding `~A' in module ~A" | |
62 | sym mod)))) | |
63 | (syntax->datum #'(identifier ...))) | |
64 | iface)) | |
65 | ||
66 | ((except import-set identifier ...) | |
67 | (and-map sym? #'(identifier ...)) | |
68 | (let* ((mod (resolve-r6rs-interface #'import-set)) | |
69 | (iface (make-custom-interface mod))) | |
70 | (module-for-each (lambda (sym var) (module-add! iface sym var)) mod) | |
71 | (for-each (lambda (sym) | |
72 | (if (module-local-variable iface sym) | |
73 | (module-remove! iface sym) | |
74 | (error "no binding `~A' in module ~A" sym mod))) | |
75 | (syntax->datum #'(identifier ...))) | |
76 | iface)) | |
77 | ||
78 | ((prefix import-set identifier) | |
79 | (sym? #'identifier) | |
80 | (let* ((mod (resolve-r6rs-interface #'import-set)) | |
81 | (iface (make-custom-interface mod)) | |
82 | (pre (syntax->datum #'identifier))) | |
83 | (module-for-each (lambda (sym var) | |
84 | (module-add! iface (symbol-append pre sym) var)) | |
85 | mod) | |
86 | iface)) | |
87 | ||
88 | ((rename import-set (from to) ...) | |
89 | (and (and-map sym? #'(from ...)) (and-map sym? #'(to ...))) | |
90 | (let* ((mod (resolve-r6rs-interface #'import-set)) | |
91 | (iface (make-custom-interface mod))) | |
92 | (module-for-each (lambda (sym var) (module-add! iface sym var)) mod) | |
93 | (let lp ((in (syntax->datum #'((from . to) ...))) (out '())) | |
94 | (cond | |
95 | ((null? in) | |
96 | (for-each | |
97 | (lambda (pair) | |
98 | (if (module-local-variable iface (car pair)) | |
99 | (error "duplicate binding for `~A' in module ~A" | |
100 | (car pair) mod) | |
101 | (module-add! iface (car pair) (cdr pair)))) | |
102 | out) | |
103 | iface) | |
104 | (else | |
105 | (let ((var (or (module-local-variable mod (caar in)) | |
106 | (error "no binding `~A' in module ~A" | |
107 | (caar in) mod)))) | |
108 | (module-remove! iface (caar in)) | |
109 | (lp (cdr in) (acons (cdar in) var out)))))))) | |
110 | ||
111 | ((name name* ... (version ...)) | |
112 | (and-map sym? #'(name name* ...)) | |
113 | (resolve-r6rs-interface #'(library (name name* ... (version ...))))) | |
114 | ||
115 | ((name name* ...) | |
116 | (and-map sym? #'(name name* ...)) | |
117 | (resolve-r6rs-interface #'(library (name name* ... ())))))) | |
118 | ||
119 | (define-syntax library | |
120 | (lambda (stx) | |
121 | (define (compute-exports ifaces specs) | |
122 | (define (re-export? sym) | |
123 | (or-map (lambda (iface) (module-local-variable iface sym)) ifaces)) | |
1052739b AW |
124 | (define (replace? sym) |
125 | (module-local-variable the-scm-module sym)) | |
b1e4c7cc | 126 | |
1052739b | 127 | (let lp ((specs specs) (e '()) (r '()) (x '())) |
b1e4c7cc | 128 | (syntax-case specs (rename) |
1052739b | 129 | (() (values e r x)) |
b1e4c7cc JG |
130 | (((rename (from to) ...) . rest) |
131 | (and (and-map identifier? #'(from ...)) | |
132 | (and-map identifier? #'(to ...))) | |
1052739b | 133 | (let lp2 ((in #'((from . to) ...)) (e e) (r r) (x x)) |
b1e4c7cc | 134 | (syntax-case in () |
1052739b | 135 | (() (lp #'rest e r x)) |
b1e4c7cc | 136 | (((from . to) . in) |
1052739b AW |
137 | (cond |
138 | ((re-export? (syntax->datum #'from)) | |
139 | (lp2 #'in e (cons #'(from . to) r) x)) | |
140 | ((replace? (syntax->datum #'from)) | |
141 | (lp2 #'in e r (cons #'(from . to) x))) | |
142 | (else | |
143 | (lp2 #'in (cons #'(from . to) e) r x))))))) | |
b1e4c7cc JG |
144 | ((id . rest) |
145 | (identifier? #'id) | |
146 | (let ((sym (syntax->datum #'id))) | |
1052739b AW |
147 | (cond |
148 | ((re-export? sym) | |
149 | (lp #'rest e (cons #'id r) x)) | |
150 | ((replace? sym) | |
151 | (lp #'rest e r (cons #'id x))) | |
152 | (else | |
153 | (lp #'rest (cons #'id e) r x)))))))) | |
b1e4c7cc JG |
154 | |
155 | (syntax-case stx (export import) | |
156 | ((_ (name name* ...) | |
157 | (export espec ...) | |
158 | (import ispec ...) | |
159 | body ...) | |
160 | (and-map identifier? #'(name name* ...)) | |
161 | ;; Add () as the version. | |
162 | #'(library (name name* ... ()) | |
163 | (export espec ...) | |
164 | (import ispec ...) | |
165 | body ...)) | |
166 | ||
167 | ((_ (name name* ... (version ...)) | |
168 | (export espec ...) | |
169 | (import ispec ...) | |
170 | body ...) | |
171 | (and-map identifier? #'(name name* ...)) | |
172 | (call-with-values | |
173 | (lambda () | |
04186f20 JG |
174 | (compute-exports |
175 | (map (lambda (im) | |
176 | (syntax-case im (for) | |
177 | ((for import-set import-level ...) | |
178 | (resolve-r6rs-interface #'import-set)) | |
179 | (import-set (resolve-r6rs-interface #'import-set)))) | |
180 | #'(ispec ...)) | |
181 | #'(espec ...))) | |
1052739b | 182 | (lambda (exports re-exports replacements) |
b1e4c7cc | 183 | (with-syntax (((e ...) exports) |
1052739b AW |
184 | ((r ...) re-exports) |
185 | ((x ...) replacements)) | |
b1e4c7cc JG |
186 | ;; It would be nice to push the module that was current before the |
187 | ;; definition, and pop it after the library definition, but I | |
188 | ;; actually can't see a way to do that. Helper procedures perhaps, | |
189 | ;; around a fluid that is rebound in save-module-excursion? Patches | |
190 | ;; welcome! | |
191 | #'(begin | |
192 | (define-module (name name* ...) | |
e6c7e9ed | 193 | #:pure |
b1e4c7cc JG |
194 | #:version (version ...)) |
195 | (import ispec) | |
196 | ... | |
b1e4c7cc | 197 | (export e ...) |
1052739b AW |
198 | (re-export r ...) |
199 | (export! x ...) | |
8210c853 | 200 | (@@ @@ (name name* ...) body) |
d9b1c71a | 201 | ...)))))))) |
b1e4c7cc JG |
202 | |
203 | (define-syntax import | |
204 | (lambda (stx) | |
ffd48603 AW |
205 | (define (strip-for import-set) |
206 | (syntax-case import-set (for) | |
207 | ((for import-set import-level ...) | |
208 | #'import-set) | |
209 | (import-set | |
210 | #'import-set))) | |
211 | (syntax-case stx () | |
212 | ((_ import-set ...) | |
213 | (with-syntax (((library-reference ...) (map strip-for #'(import-set ...)))) | |
214 | #'(eval-when (eval load compile expand) | |
215 | (let ((iface (resolve-r6rs-interface 'library-reference))) | |
216 | (call-with-deferred-observers | |
217 | (lambda () | |
218 | (module-use-interfaces! (current-module) (list iface))))) | |
219 | ... | |
b1e4c7cc | 220 | (if #f #f))))))) |