blob: e2e682e6a13bc18601913cb25eb91a9ec5469d61 (
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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
(define-library (csc compiler)
(export
add-library-search-dirs
compile)
(import (scheme base)
(csc format)
(only (scheme file)
call-with-input-file
file-exists?)
(only (scheme read)
read)
(only (csc codegen)
ir2->ir3)
(only (csc config)
*standard-library-dir*)
(only (csc cps)
closure-convert
ir1->ir2)
(only (csc encoding)
encode)
(only (csc format)
sprintf)
(only (csc hash-map)
compare-symbols
hash-bytevector
insert
key-not-found-error?
lookup
make-comparer
make-map
merge)
(only (csc ir1)
%define-syntax
%library-define
%library-ref
%sequence)
(only (csc ir2)
*tail*)
(only (csc linker)
link)
(only (csc list)
revappend)
(only (csc loop)
loop
return)
(only (csc macros)
builtins-environment
expand-body)
(only (csc match)
match)
(only (csc strings)
join
last-index))
(begin
(define (dirname f)
(define i (last-index f "/"))
(if (negative? i)
"."
(substring f 0 i)))
(define (read-file f)
(call-with-input-file f
(lambda (p)
(loop for expr = (read p)
until (eof-object? expr)
collect expr))))
(define (normalize-library lib-file)
(define dir (dirname lib-file))
(define lib (call-with-input-file lib-file read))
(match lib
(('define-library name . declarations)
(define decls
(loop for decl in declarations
if (match decl (('include-library-declarations _) #t)
(_ #f))
append (read-file (sprintf "{}/{}" dir (cadr decl)))
else collect decl))
(loop for decl in decls
if (match decl (('export . _) #t)
(_ #f))
append (cdr decl) into exports
else if (match decl (('import . _) #t)
(_ #f))
append (cdr decl) into imports
else if (match decl (('begin . _) #t)
(_ #f))
append (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-dirs* '())
(define (add-library-search-dirs ds)
(set! *library-search-dirs* (append *library-search-dirs* ds)))
(define (find-library name)
(define library-roots (cons *standard-library-dir* *library-search-dirs*))
(loop for dir in library-roots
for file-path = (loop for part in name
collect (symbol->string part) into path
finally (return (sprintf "{}/{}.csc" dir (join "/" 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)
(define c (closure-convert (ir1->ir2 expr (lambda (x) *tail*))))
(printf "ir2 =\n{}\n" c)
(define b (ir2->ir3 c))
(printf "ir3 =\n{}\n" b)
b)
; 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 (load-library import)))
finally (return env)))
(define library-code '())
(define (compile-library lib-file)
(define lib (normalize-library lib-file))
(match lib
(('define-library library-name
('export . exports)
('import . imports)
('begin . body))
(define env (make-import-map imports))
(define expanded-body (expand-body library-name body env))
(let loop ((expr expanded-body))
(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))
exported-symbols)
(_ (error "unexpected form in compile-library" lib))))
(define (load-library lib)
(match lib
(('only lib . symbols)
(define m (load-library lib))
(define m* (make-map compare-symbols))
(for-each (lambda (symb)
(set! m* (insert m* symb (guard (e ((key-not-found-error? e) (error "symbol does not exist in library" symb)))
(lookup m symb)))))
symbols)
m*)
('(csc builtins)
builtins-environment)
(_ (or (lookup library-symbols lib #f)
(compile-library (find-library lib))))))
(match program
((('import . imports1) ('import . imports2) . rest)
(compile (cons (cons 'import (append imports1 imports2)) rest)))
((('import . imports) . body)
(printf "imports {}\n" imports)
(define compiled-body (ir1->bytecode (expand-body 'main body (make-import-map imports))))
(encode (link (revappend library-code (list compiled-body (list (list 'exit (list 'const 0))))))))
(_ (error "unexpected form in compile" program))))))
|
