source: project/modules/trunk/modules-base.scm @ 7273

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

updates

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