source: project/release/3/modules/trunk/modules-base.scm @ 8486

Last change on this file since 8486 was 8486, checked in by felix winkelmann, 12 years ago

handle empty export list

File size: 8.4 KB
Line 
1;;;; modules-base.scm
2
3
4#+(not csi)
5(declare
6  (export modules:expand-module
7          modules:expand-import
8          modules:expand-import*
9          modules:expand-export-toplevel) )
10
11
12(use miscmacros srfi-1 codewalk)
13
14
15(define-record module 
16  name                                  ; STRING
17  exports)                              ; ((SYMBOL . ALIAS) ...)
18
19(define-record context
20  current-module
21  current-imports
22  assigned
23  hidden)
24
25(define *debug-modules* (feature? 'debug-modules))
26(define *modules* '())
27(define context (make-parameter (make-context #f '() '() '())))
28
29(define (modules:expand-module args)
30  (match args
31    (((exports ...) . body)
32     (expand-module (guid) #t exports body) )
33    ((name (exports ...) . body)
34     (expand-module name #f exports body) )
35    (_ (syntax-error 'module "invalid module syntax" args)) ) )
36
37(define (modules:expand-import mod)
38  (let ((c (context))
39        (imps (resolve-module mod)) )
40    (cond ((context-current-module c)
41           (context-current-imports-set! c (append imps (context-current-imports c)))
42           `(##core#undefined))
43          (else
44           (let ((tmp (gensym)))
45             `(let ((,tmp (lambda (sym)
46                            (warning (sprintf ,(conc "imported toplevel binding `~s' from module `" 
47                                                     mod "' overwrites existing value")
48                                              sym) ) ) ) )
49                (void)
50                ,@(map (lambda (imp) 
51                         `(begin
52                            (if (##sys#symbol-has-toplevel-binding? ',(car imp))
53                                (,tmp ',(car imp)) )
54                            (set! ,(car imp) ,(cdr imp))) )
55                       imps) ) ) ) ) ) )
56
57(define (modules:expand-import* mod is)
58  (define (filter-imports imps)
59    (filter-map
60     (match-lambda
61       ((new old) 
62        (cons
63         new
64         (cond ((assq old imps) => cdr)
65               (else (syntax-error 'import* "module does not export binding" mod old)) ) ) )
66       (id (or (assq id imps)
67               (syntax-error 'import* "module does not export binding" mod old)) ) )
68     is) )
69  (let ((c (context))
70        (imps (resolve-module mod)) )
71    (cond ((context-current-module c)
72           (context-current-imports-set!
73            c
74            (append
75             (filter-imports imps)
76             (context-current-imports c)))
77           `(##core#undefined))
78          (else
79           (let ((tmp (gensym)))
80             `(let ((,tmp (lambda (sym)
81                            (warning (sprintf ,(conc "imported toplevel binding `~s' from module `" 
82                                                     mod "' overwrites existing value")
83                                              sym) ) ) ) )
84                ,@(map (lambda (imp) 
85                         `(begin
86                            (if (##sys#symbol-has-toplevel-binding? ',(car imp))
87                                (,tmp ',(car imp)) )
88                            (set! ,(car imp) ,(cdr imp))) )
89                       (filter-imports imps) ) ) ) ) ) ) )
90
91(define (modules:expand-export-toplevel args)   ; suggested by Kon Lovett
92  (let loop ([forms args] [body '(begin)])
93    (if (null? forms)
94      (reverse body)
95      (let ([form (car forms)])
96        (loop (cdr forms)
97          (cons
98            (if (list? form)
99              `(##sys#setslot ',(cadr form) 0 ,(car form))
100              `(##sys#setslot ',form 0 ,form) )
101            body)) ) ) ) )
102
103(define (register-module name exps)
104  (cond ((find (lambda (m) (equal? name (module-name m))) *modules*) =>
105         (lambda (m) 
106           (module-exports-set! m exps)
107           m) )
108        (else
109         (let ((m (make-module name exps)))
110           (push! m *modules*)
111           m) ) ) )
112
113(define (expand-cond-expand clauses)
114  (define (check t)
115    (match t
116      (('and ts ...) (every check ts))
117      (('or ts ...) (any check ts))
118      (('not t) (not (check t)))
119      ((? symbol? f) (feature? f))
120      (else (syntax-error 'cond-expand "invalid conditional expression in `cond-expand'" f)) ) )
121  (let loop ((clauses clauses))
122    (match clauses
123      (() (syntax-error 'cond-expand "no matching `cond-expand' clause" clauses))
124      ((('else . body) . _)
125       `(begin ,@body) )
126      (((test . body) . more)
127       (if (check test)
128           `(begin ,@body)
129           (loop more) ) )
130      (c (syntax-error 'cond-expand "invalid `cond-expand' clause" c)) ) ) )
131
132(define (preexpand body)
133  (let ((c (context)))
134    (define (process name)
135      (cond ((assq name (module-exports (context-current-module c))) =>
136             (lambda (exp) 
137               (context-assigned-set! c (cons (cdr exp) (context-assigned c)))
138               (rename name)) )
139            (else
140             (let ((r (generate-id name #f)))
141               (context-hidden-set! c (cons (cons name r) (context-hidden c)))
142               r) ) ) )
143    (define (expand form)
144      (when *debug-modules* (pp `(PREEXPAND: ,form)))
145      (match form
146        (('begin . body)
147         `(begin ,@(map expand body) ) )
148        (((and def (or 'define 'define*)) ((? pair? head) . llist) . body)
149         (expand `(,def ,head (lambda ,llist ,@body))) )
150        (((and def (or 'define 'define*)) (name . llist) . body)
151         `(,def (,(process name) ,@llist) ,@body) )
152        (((and def (or 'define 'define*)) name val)
153         `(,def ,(process name) ,val) )
154        (('define-values (vars ...) val)
155         `(define-values ,(map process vars) ,val))
156        (('cond-expand clauses ...)
157         (expand (expand-cond-expand clauses) ) )
158        (('include file)
159         (let ((f (or (file-exists? (##sys#resolve-include-filename file #t #f))
160                      (file-exists? (##sys#resolve-include-filename (string-append file ".scm") #t #f)) ) ) )
161           (let ((forms (read-file f)))
162             `(begin ,@(map expand forms) ) ) ) )
163        (x x) ) )
164    (map expand body) ) )
165
166(define (expand-module name anon exports body)
167  (let* ((sname (->string name))
168         (exps (map (match-lambda
169                      ((or (id . _) id)
170                       (cons id (generate-id id sname))) )
171                    exports) ) )
172    (parameterize ((context 
173                    (make-context 
174                     (if anon (make-module name exps) (register-module name exps))
175                     (context-current-imports (context))
176                     '() 
177                     '() ) ) )               
178      (let ((result
179             (expand/context 
180              `(begin ,@(preexpand body))
181              (expansion-context classes: '(ref set! let lambda))
182              module-expander) ) )
183        (for-each
184         (lambda (exp)
185           (unless (memq (cdr exp) (context-assigned (context)))
186             (error name "exported identifier has not been initialized" (car exp)) ) )
187         exps)
188        result) ) ) )
189
190(define (guid)                          ; well, sort of...
191  (string-append
192   (number->string (##sys#fudge 2)) 
193   (number->string (random #x1000000)) ) )
194
195(define (generate-id name prefix)
196  (string->symbol
197   (string-append
198    (or prefix (guid))
199    "$$"
200    (symbol->string name)) ) )
201
202(define (rename id)
203  (let ((c (context)))
204    (cond ((assq id (context-current-imports c)) => cdr)
205          ((assq id (context-hidden c)) => cdr)
206          (else
207           (let ((cm (context-current-module c)))
208             (let ((exp (and cm (assq id (module-exports cm)))))
209               (if exp (cdr exp) id) ) ) ) ) ) )
210
211(define (extract-exports name)
212  (define (split syms)
213    (let ((sname (->string name)))
214      (let loop ((syms syms) (exps '()))
215        (if (null? syms)
216            exps
217            (let ((s (car syms)))
218              (loop
219               (cdr syms)
220               (if (symbol? s)
221                   (let* ((str (symbol->string s))
222                          (i (substring-index "$$" str)) )
223                     (if (and i (string=? sname (substring str 0 i)))
224                         (cons (cons (string->symbol (substring str (fx+ i 2))) s) exps)
225                         exps) )
226                   exps) ) ) ) ) ) )
227  (define (try-file)
228    (let ((f (file-exists? (##sys#resolve-include-filename (conc name ".exports") #t #t))))
229      (and f
230           (begin
231             (if (load-verbose) (print "; reading exports file " f " ..."))
232             (let ((exps (split (read-file f))))
233               (and (pair? exps) exps) ) ) ) ) )
234  (cond ((extension-information name) =>
235         (lambda (info)
236           (let ((a (assq 'exports info)))
237             (if a
238                 (let ((exps (split (cdr a))))
239                   (if (null? exps)
240                       (or (try-file) '())
241                       exps) )
242                 (try-file)) ) ) )
243        (else (try-file)) ) )
244
245(define (resolve-module name)
246  (cond ((find (lambda (m) (equal? name (module-name m))) *modules*) =>
247         (lambda (a) (module-exports a)))
248        ((extract-exports name) =>
249         (lambda (exps)
250           (register-module name exps)
251           exps) )
252        (else (error 'import "undefined module" name)) ) )
253
254(define (module-expander x c w e m)
255  ;(pp `(MEXPAND: ,x))
256  (case c
257    ((ref) (rename x))
258    ((set!) 
259     (let ((dest (cadr x))
260           (val (caddr x)))
261       (cond ((pair? dest) `(set! ,(w dest) ,(w val)) )
262             (else `(set! ,(rename dest) ,(w val))) ) ) )
263    ((let)
264     (let* ((c (context))
265            (ci (context-current-imports c) ) 
266            (exp `(let ,(map (lambda (b) (list (rename (car b)) (w (cadr b)))) (cadr x))
267                    ,(w (caddr x)))) )
268       (context-current-imports-set! c ci)
269       exp) )
270    ((lambda)
271     (##sys#decompose-lambda-list
272      (cadr x)
273      (lambda (vars argc rest)
274        (let* ((c (context))
275               (ci (context-current-imports c))
276               (exp `(lambda ,(append (map rename (if rest (butlast vars) vars)) (if rest (rename rest) '()))
277                       ,(w (caddr x)))))
278          (context-current-imports-set! c ci)
279          exp) ) ) )
280    (else (error "codewalk broken - this shouldn't happen" c))) )
Note: See TracBrowser for help on using the repository browser.