blob: ee0b3b432e031d7f10274c863418010e834d2fba (
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
|
(define-library (csc compiler)
(export
*library-search-dirs*
compile)
(import (scheme base)
(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 linker)
link)
(only (csc list)
revappend)
(only (csc loop)
loop
return)
(only (csc macros)
expand-body)
(only (csc match)
match)
(only (csc strings)
join))
(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-dirs* '())
(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 (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 (lambda (x) *tail*)))))
; 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 expanded-body (expand-body library-name body env))
(define env (make-import-map imports))
(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)))
(_ (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))))
(encode (link (revappend library-code (list compiled-body)))))
(_ (error "unexpected form in compile" program))))))
|
