blob: 4f1cafcae25af04577febbafc35c5e421b147853 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
(define-library (csc compiler)
(export
*library-search-dir*
compile)
(import (scheme base)
(only (csc codegen)
ir2->ir3)
(only (csc config)
*standard-library-dir*)
(only (csc cps)
closure-convert
ir1->ir2)
(only (csc format)
sprintf)
(only (csc hash-map)
hash-bytevector
make-comparer
make-map
merge)
(only (csc linker)
link)
(only (csc list)
revappend)
(only (csc match)
match)
(only (scheme file)
file-exists?))
(begin
(define (normalize-library lib)
(match lib
(('define-library name . declarations)
(loop for decl in declarations
if (match decl (('export . _) #t)
(_ #f))
collect (cdr decl) into exports
else if (match decl (('import . _) #t)
(_ #f))
collect (cdr decl) into imports
else if (match decl (('begin . _) #t)
(_ #f))
collect (cdr decl) into body
else
do (error "unexpected form in normalize-library" decl)
finally (return (list 'define-library name
(cons 'export exports)
(cons 'import imports)
(cons 'begin body)))))
(_ (error "unexpected form in normalize-library" lib))))
(define compare-library-names
(make-comparer
(lambda (x)
(hash-bytevector (string->utf8 (sprintf "{}" x))))
(lambda (x y)
(cond
((equal? x y) 0)
((string<? (sprintf "{}" x) (sprintf "{}" y)) -1)
(else 1)))))
(define *library-search-dir* #f)
(define (find-library name)
(define library-roots (list *standard-library-dir*))
(when *library-search-dir*
(set! library-roots (cons *library-search-dir* library-roots)))
(loop for dir in library-roots
for file-path = (loop for part in name
collect (symbol->string part) into path
finally (return (join "/" (cons dir path))))
if (file-exists? file-path)
return file-path
else
collect file-path into bad-paths
finally (error "unable to find library" name bad-paths)))
(define (ir1->bytecode expr)
(ir2->ir3 (closure-convert (ir1->ir2 expr))))
; compile turns scheme code into bytecode.
(define (compile program)
(define library-symbols (make-map compare-library-names))
(define (make-import-map imports)
(define env (make-map compare-symbols))
(loop for import in imports
do (set! env
(merge env
(or (lookup library-symbols import #f)
(call-with-input-file (find-library import)
(lambda (f)
(compile-library (read f)))))))
finally (return env)))
(define library-code '())
(define (compile-library lib)
(match (normalize-library lib)
(('define-library library-name
('export . exports)
('import . imports)
('begin . body))
(define env (make-import-map imports))
(let loop ((expr (expand-body library-name body env)))
(match expr
((% %library-define (% %library-ref name _) val)
(set! env (insert env name val)))
((% %define-syntax name val)
(set! env (insert env name val)))
((% %sequence head tail)
(loop head)
(loop tail))))
(define exported-symbols (make-map compare-symbols))
(loop for sym in exports
do (set! exported-symbols
(insert exported-symbols sym
(guard (e ((key-not-found-error? e) (error "exported symbol was not defined in the library" sym)))
(lookup env sym)))))
(set! library-symbols (insert library-symbols library-name exported-symbols))
(set! library-code (cons (ir1->bytecode expanded-body) library-code)))
(_ (error "unexpected form in compile-library" lib))))
(match program
((('import . imports1) ('import . imports2) . rest)
(compile (cons (list 'import (append imports1 imports2)) rest)))
((('import . imports) . body)
(define compiled-body (ir1->bytecode (expand-body 'main body (make-import-map imports))))
(link (revappend library-code (list compiled-body)))
(_ (error "unexpected form in compile" program))))))
|
