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

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

added preexpansion hook (internal)

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