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) | |
32 | ;; (srfi :n ...) -> (srfi srfi-n ...) | |
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 | |
43 | #`(library (srfi #,srfi-n rest ... (version ...)))))) | |
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)) | |
124 | ||
125 | (let lp ((specs specs) (e '()) (r '())) | |
126 | (syntax-case specs (rename) | |
127 | (() (values e r)) | |
128 | (((rename (from to) ...) . rest) | |
129 | (and (and-map identifier? #'(from ...)) | |
130 | (and-map identifier? #'(to ...))) | |
131 | (let lp2 ((in #'((from . to) ...)) (e e) (r r)) | |
132 | (syntax-case in () | |
133 | (() (lp #'rest e r)) | |
134 | (((from . to) . in) | |
135 | (if (re-export? (syntax->datum #'from)) | |
136 | (lp2 #'in e (cons #'(from . to) r)) | |
137 | (lp2 #'in (cons #'(from . to) e) r)))))) | |
138 | ((id . rest) | |
139 | (identifier? #'id) | |
140 | (let ((sym (syntax->datum #'id))) | |
141 | (if (re-export? sym) | |
142 | (lp #'rest e (cons #'id r)) | |
143 | (lp #'rest (cons #'id e) r))))))) | |
144 | ||
145 | (syntax-case stx (export import) | |
146 | ((_ (name name* ...) | |
147 | (export espec ...) | |
148 | (import ispec ...) | |
149 | body ...) | |
150 | (and-map identifier? #'(name name* ...)) | |
151 | ;; Add () as the version. | |
152 | #'(library (name name* ... ()) | |
153 | (export espec ...) | |
154 | (import ispec ...) | |
155 | body ...)) | |
156 | ||
157 | ((_ (name name* ... (version ...)) | |
158 | (export espec ...) | |
159 | (import ispec ...) | |
160 | body ...) | |
161 | (and-map identifier? #'(name name* ...)) | |
162 | (call-with-values | |
163 | (lambda () | |
164 | (compute-exports (map resolve-r6rs-interface #'(ispec ...)) | |
165 | #'(espec ...))) | |
166 | (lambda (exports re-exports) | |
167 | (with-syntax (((e ...) exports) | |
168 | ((r ...) re-exports)) | |
169 | ;; It would be nice to push the module that was current before the | |
170 | ;; definition, and pop it after the library definition, but I | |
171 | ;; actually can't see a way to do that. Helper procedures perhaps, | |
172 | ;; around a fluid that is rebound in save-module-excursion? Patches | |
173 | ;; welcome! | |
174 | #'(begin | |
175 | (define-module (name name* ...) | |
e6c7e9ed | 176 | #:pure |
b1e4c7cc JG |
177 | #:version (version ...)) |
178 | (import ispec) | |
179 | ... | |
180 | (re-export r ...) | |
181 | (export e ...) | |
d9b1c71a AW |
182 | (@@ (name name* ...) body) |
183 | ...)))))))) | |
b1e4c7cc JG |
184 | |
185 | (define-syntax import | |
186 | (lambda (stx) | |
187 | (syntax-case stx (for) | |
188 | ((_ (for import-set import-level ...)) | |
189 | #'(import import-set)) | |
190 | ((_ import-set) | |
e6c7e9ed | 191 | #'(eval-when (eval load compile expand) |
b1e4c7cc JG |
192 | (let ((iface (resolve-r6rs-interface 'import-set))) |
193 | (call-with-deferred-observers | |
194 | (lambda () | |
195 | (module-use-interfaces! (current-module) (list iface)))) | |
196 | (if #f #f))))))) |