1 ;;; r6rs-libraries.scm --- Support for the R6RS `library' and `import' forms
3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
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.
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.
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
20 ;; This file is included from boot-9.scm and assumes the existence of (and
21 ;; expands into) procedures and syntactic forms defined therein.
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))
29 (define (sym? x) (symbol? (syntax->datum x)))
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
40 (substring (symbol->string (syntax->datum #'colon-n))
42 (resolve-r6rs-interface
43 (syntax-case #'(rest ...) ()
45 #`(library (srfi #,srfi-n (version ...))))
47 ;; SRFI 97 says that the first identifier after the colon-n
48 ;; is used for the libraries name, so it must be ignored.
49 #`(library (srfi #,srfi-n rest ... (version ...))))))))
51 ((library (name name* ... (version ...)))
52 (and-map sym? #'(name name* ...))
53 (resolve-interface (syntax->datum #'(name name* ...))
54 #:version (syntax->datum #'(version ...))))
56 ((library (name name* ...))
57 (and-map sym? #'(name name* ...))
58 (resolve-r6rs-interface #'(library (name name* ... ()))))
60 ((only import-set identifier ...)
61 (and-map sym? #'(identifier ...))
62 (let* ((mod (resolve-r6rs-interface #'import-set))
63 (iface (make-custom-interface mod)))
64 (for-each (lambda (sym)
65 (module-add! iface sym
66 (or (module-local-variable mod sym)
67 (error "no binding `~A' in module ~A"
69 (syntax->datum #'(identifier ...)))
72 ((except import-set identifier ...)
73 (and-map sym? #'(identifier ...))
74 (let* ((mod (resolve-r6rs-interface #'import-set))
75 (iface (make-custom-interface mod)))
76 (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
77 (for-each (lambda (sym)
78 (if (module-local-variable iface sym)
79 (module-remove! iface sym)
80 (error "no binding `~A' in module ~A" sym mod)))
81 (syntax->datum #'(identifier ...)))
84 ((prefix import-set identifier)
86 (let* ((mod (resolve-r6rs-interface #'import-set))
87 (iface (make-custom-interface mod))
88 (pre (syntax->datum #'identifier)))
89 (module-for-each (lambda (sym var)
90 (module-add! iface (symbol-append pre sym) var))
94 ((rename import-set (from to) ...)
95 (and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
96 (let* ((mod (resolve-r6rs-interface #'import-set))
97 (iface (make-custom-interface mod)))
98 (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
99 (let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
104 (if (module-local-variable iface (car pair))
105 (error "duplicate binding for `~A' in module ~A"
107 (module-add! iface (car pair) (cdr pair))))
111 (let ((var (or (module-local-variable mod (caar in))
112 (error "no binding `~A' in module ~A"
114 (module-remove! iface (caar in))
115 (lp (cdr in) (acons (cdar in) var out))))))))
117 ((name name* ... (version ...))
118 (and-map sym? #'(name name* ...))
119 (resolve-r6rs-interface #'(library (name name* ... (version ...)))))
122 (and-map sym? #'(name name* ...))
123 (resolve-r6rs-interface #'(library (name name* ... ()))))))
125 (define-syntax library
127 (define (compute-exports ifaces specs)
128 (define (re-export? sym)
129 (or-map (lambda (iface) (module-local-variable iface sym)) ifaces))
130 (define (replace? sym)
131 (module-local-variable the-scm-module sym))
133 (let lp ((specs specs) (e '()) (r '()) (x '()))
134 (syntax-case specs (rename)
136 (((rename (from to) ...) . rest)
137 (and (and-map identifier? #'(from ...))
138 (and-map identifier? #'(to ...)))
139 (let lp2 ((in #'((from . to) ...)) (e e) (r r) (x x))
141 (() (lp #'rest e r x))
144 ((re-export? (syntax->datum #'from))
145 (lp2 #'in e (cons #'(from . to) r) x))
146 ((replace? (syntax->datum #'from))
147 (lp2 #'in e r (cons #'(from . to) x)))
149 (lp2 #'in (cons #'(from . to) e) r x)))))))
152 (let ((sym (syntax->datum #'id)))
155 (lp #'rest e (cons #'id r) x))
157 (lp #'rest e r (cons #'id x)))
159 (lp #'rest (cons #'id e) r x))))))))
161 (syntax-case stx (export import)
166 (and-map identifier? #'(name name* ...))
167 ;; Add () as the version.
168 #'(library (name name* ... ())
173 ((_ (name name* ... (version ...))
177 (and-map identifier? #'(name name* ...))
182 (syntax-case im (for)
183 ((for import-set import-level ...)
184 (resolve-r6rs-interface #'import-set))
185 (import-set (resolve-r6rs-interface #'import-set))))
188 (lambda (exports re-exports replacements)
189 (with-syntax (((e ...) exports)
191 ((x ...) replacements))
192 ;; It would be nice to push the module that was current before the
193 ;; definition, and pop it after the library definition, but I
194 ;; actually can't see a way to do that. Helper procedures perhaps,
195 ;; around a fluid that is rebound in save-module-excursion? Patches
198 (define-module (name name* ...)
200 #:version (version ...))
206 (@@ @@ (name name* ...) body)
209 (define-syntax import
211 (define (strip-for import-set)
212 (syntax-case import-set (for)
213 ((for import-set import-level ...)
219 (with-syntax (((library-reference ...) (map strip-for #'(import-set ...))))
220 #'(eval-when (expand load eval)
221 (let ((iface (resolve-r6rs-interface 'library-reference)))
222 (call-with-deferred-observers
224 (module-use-interfaces! (current-module) (list iface)))))