Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Guile High Intermediate Language |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (system il ghil) | |
17e90c5e | 23 | :use-syntax (system base syntax) |
17e90c5e KN |
24 | :use-module (ice-9 regex) |
25 | :export | |
01967b69 | 26 | (<ghil-void> make-ghil-void ghil-void? |
bdaffda2 | 27 | ghil-void-env ghil-void-loc |
01967b69 AW |
28 | |
29 | <ghil-quote> make-ghil-quote ghil-quote? | |
bdaffda2 | 30 | ghil-quote-env ghil-quote-loc ghil-quote-obj |
01967b69 AW |
31 | |
32 | <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote? | |
bdaffda2 | 33 | ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp |
01967b69 AW |
34 | |
35 | <ghil-unquote> make-ghil-unquote ghil-unquote? | |
bdaffda2 | 36 | ghil-unquote-env ghil-unquote-loc ghil-unquote-exp |
01967b69 AW |
37 | |
38 | <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing? | |
bdaffda2 | 39 | ghil-unquote-env ghil-unquote-loc ghil-unquote-exp |
cb4cca12 | 40 | |
01967b69 | 41 | <ghil-ref> make-ghil-ref ghil-ref? |
bdaffda2 | 42 | ghil-ref-env ghil-ref-loc ghil-ref-var |
01967b69 AW |
43 | |
44 | <ghil-set> make-ghil-set ghil-set? | |
bdaffda2 | 45 | ghil-set-env ghil-set-loc ghil-set-var ghil-set-val |
01967b69 AW |
46 | |
47 | <ghil-define> make-ghil-define ghil-define? | |
bdaffda2 | 48 | ghil-define-env ghil-define-loc ghil-define-var ghil-define-val |
cb4cca12 | 49 | |
01967b69 | 50 | <ghil-if> make-ghil-if ghil-if? |
bdaffda2 | 51 | ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else |
01967b69 AW |
52 | |
53 | <ghil-and> make-ghil-and ghil-and? | |
bdaffda2 | 54 | ghil-and-env ghil-and-loc ghil-and-exps |
01967b69 AW |
55 | |
56 | <ghil-or> make-ghil-or ghil-or? | |
bdaffda2 | 57 | ghil-or-env ghil-or-loc ghil-or-exps |
01967b69 AW |
58 | |
59 | <ghil-begin> make-ghil-begin ghil-begin? | |
bdaffda2 | 60 | ghil-begin-env ghil-begin-loc ghil-begin-exps |
01967b69 AW |
61 | |
62 | <ghil-bind> make-ghil-bind ghil-bind? | |
bdaffda2 | 63 | ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body |
01967b69 AW |
64 | |
65 | <ghil-lambda> make-ghil-lambda ghil-lambda? | |
bdaffda2 | 66 | ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body |
01967b69 AW |
67 | |
68 | <ghil-inline> make-ghil-inline ghil-inline? | |
bdaffda2 | 69 | ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args |
01967b69 AW |
70 | |
71 | <ghil-call> make-ghil-call ghil-call? | |
bdaffda2 | 72 | ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args |
aa0a011b | 73 | |
01967b69 AW |
74 | <ghil-var> make-ghil-var ghil-var? |
75 | ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value | |
76 | ghil-var-index | |
aa0a011b | 77 | |
01967b69 AW |
78 | <ghil-mod> make-ghil-mod ghil-mod? |
79 | ghil-mod-module ghil-mod-table ghil-mod-imports | |
aa0a011b | 80 | |
01967b69 | 81 | <ghil-env> make-ghil-env ghil-env? |
77046be3 AW |
82 | ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables |
83 | ||
cd9d95d7 | 84 | ghil-primitive-macro? ghil-env-add! ghil-lookup ghil-define |
859f6390 | 85 | ghil-env-toplevel? |
77046be3 | 86 | call-with-ghil-environment call-with-ghil-bindings)) |
17e90c5e KN |
87 | |
88 | \f | |
89 | ;;; | |
90 | ;;; Parse tree | |
91 | ;;; | |
92 | ||
ac99cb0c KN |
93 | (define-type <ghil> |
94 | (| | |
95 | ;; Objects | |
96 | (<ghil-void> env loc) | |
97 | (<ghil-quote> env loc obj) | |
98 | (<ghil-quasiquote> env loc exp) | |
99 | (<ghil-unquote> env loc exp) | |
100 | (<ghil-unquote-splicing> env loc exp) | |
101 | ;; Variables | |
102 | (<ghil-ref> env loc var) | |
103 | (<ghil-set> env loc var val) | |
104 | (<ghil-define> env loc var val) | |
105 | ;; Controls | |
106 | (<ghil-if> env loc test then else) | |
107 | (<ghil-and> env loc exps) | |
108 | (<ghil-or> env loc exps) | |
109 | (<ghil-begin> env loc exps) | |
110 | (<ghil-bind> env loc vars vals body) | |
111 | (<ghil-lambda> env loc vars rest body) | |
112 | (<ghil-call> env loc proc args) | |
113 | (<ghil-inline> env loc inline args))) | |
114 | ||
17e90c5e | 115 | \f |
46cd9a34 KN |
116 | ;;; |
117 | ;;; Procedures | |
118 | ;;; | |
119 | ||
120 | (define *core-primitives* | |
121 | '(@void @quote @define @set! @if @begin @let @letrec @lambda)) | |
122 | ||
123 | (define *macro-module* (resolve-module '(system il macros))) | |
124 | ||
77046be3 | 125 | (define (ghil-primitive-macro? x) |
25ec54b5 KN |
126 | (and (module-defined? *macro-module* x) |
127 | (procedure? (module-ref *macro-module* x)))) | |
46cd9a34 KN |
128 | |
129 | (define (ghil-macro-expander x) | |
130 | (module-ref *macro-module* x)) | |
131 | ||
132 | (define (ghil-primitive? x) | |
133 | (or (memq x *core-primitives*) | |
134 | (ghil-primitive-macro? x))) | |
135 | ||
136 | \f | |
17e90c5e KN |
137 | ;;; |
138 | ;;; Variables | |
139 | ;;; | |
140 | ||
ac99cb0c | 141 | (define-record (<ghil-var> env name kind (type #f) (value #f) (index #f))) |
cb4cca12 | 142 | |
17e90c5e KN |
143 | \f |
144 | ;;; | |
145 | ;;; Modules | |
146 | ;;; | |
147 | ||
ac99cb0c | 148 | (define-record (<ghil-mod> module (table '()) (imports '()))) |
17e90c5e KN |
149 | |
150 | \f | |
151 | ;;; | |
152 | ;;; Environments | |
153 | ;;; | |
154 | ||
ac99cb0c | 155 | (define-record (<ghil-env> mod parent (table '()) (variables '()))) |
17e90c5e | 156 | |
849cefac | 157 | (define %make-ghil-env make-ghil-env) |
77046be3 | 158 | (define (make-ghil-env e) |
849cefac AW |
159 | (record-case e |
160 | ((<ghil-mod>) (%make-ghil-env :mod e :parent e)) | |
f540e327 | 161 | ((<ghil-env> mod) (%make-ghil-env :mod mod :parent e)))) |
17e90c5e | 162 | |
66292535 | 163 | (define (ghil-env-toplevel? e) |
859f6390 | 164 | (eq? (ghil-env-mod e) (ghil-env-parent e))) |
66292535 | 165 | |
ac99cb0c | 166 | (define (ghil-env-ref env sym) |
61dc81d9 AW |
167 | (assq-ref (ghil-env-table env) sym)) |
168 | ||
169 | (define-macro (push! item loc) | |
170 | `(set! ,loc (cons ,item ,loc))) | |
171 | (define-macro (apush! k v loc) | |
172 | `(set! ,loc (acons ,k ,v ,loc))) | |
173 | (define-macro (apopq! k loc) | |
cd702346 | 174 | `(set! ,loc (assq-remove! ,loc ,k))) |
17e90c5e | 175 | |
77046be3 | 176 | (define (ghil-env-add! env var) |
61dc81d9 AW |
177 | (apush! (ghil-var-name var) var (ghil-env-table env)) |
178 | (push! var (ghil-env-variables env))) | |
17e90c5e | 179 | |
ac99cb0c | 180 | (define (ghil-env-remove! env var) |
61dc81d9 | 181 | (apopq! (ghil-var-name var) (ghil-env-table env))) |
17e90c5e | 182 | |
ac99cb0c KN |
183 | \f |
184 | ;;; | |
185 | ;;; Public interface | |
186 | ;;; | |
187 | ||
5e1cead4 AW |
188 | (define (module-lookup module sym) |
189 | (let ((iface (module-import-interface module sym))) | |
190 | (and iface | |
191 | (make-ghil-env (make-ghil-mod iface))))) | |
192 | ||
cd702346 AW |
193 | (define (fix-ghil-mod! mod for-sym) |
194 | (warn "during lookup of" for-sym ":" (ghil-mod-module mod) "!= current" (current-module)) | |
195 | (if (not (null? (ghil-mod-table mod))) | |
196 | (warn "throwing away old variable table" (ghil-mod-table mod))) | |
197 | (set! (ghil-mod-module mod) (current-module)) | |
198 | (set! (ghil-mod-table mod) '()) | |
199 | (set! (ghil-mod-imports mod) '())) | |
200 | ||
61dc81d9 | 201 | ;; looking up a var has side effects? |
77046be3 | 202 | (define (ghil-lookup env sym) |
17e90c5e | 203 | (or (ghil-env-ref env sym) |
61dc81d9 AW |
204 | (let loop ((e (ghil-env-parent env))) |
205 | (record-case e | |
206 | ((<ghil-mod> module table imports) | |
cd702346 AW |
207 | (cond ((not (eq? module (current-module))) |
208 | ;; FIXME: the primitive-eval in eval-case and/or macro | |
209 | ;; expansion can have side effects on the compilation | |
210 | ;; environment, for example changing the current | |
211 | ;; module. We probably need to add a special case in | |
212 | ;; compilation to handle define-module. | |
213 | (fix-ghil-mod! e sym) | |
214 | (loop e)) | |
215 | ((assq-ref table sym)) ;; when does this hit? | |
5e1cead4 AW |
216 | ((module-lookup module sym) |
217 | => (lambda (found-env) | |
218 | (make-ghil-var found-env sym 'module))) | |
219 | (else | |
220 | ;; a free variable that we have not resolved | |
cd702346 AW |
221 | (if (not (module-locally-bound? module sym)) |
222 | ;; For the benefit of repl compilation, that | |
223 | ;; doesn't compile modules all-at-once, don't warn | |
224 | ;; if we find the symbol locally. | |
225 | (warn "unresolved variable during compilation:" sym)) | |
5e1cead4 | 226 | (make-ghil-var #f sym 'module)))) |
61dc81d9 AW |
227 | ((<ghil-env> mod parent table variables) |
228 | (let ((found (assq-ref table sym))) | |
229 | (if found | |
230 | (begin (set! (ghil-var-kind found) 'external) found) | |
231 | (loop parent)))))))) | |
17e90c5e | 232 | |
cd9d95d7 | 233 | (define (ghil-define mod sym) |
cd702346 AW |
234 | (if (not (eq? (ghil-mod-module mod) (current-module))) |
235 | (fix-ghil-mod! mod sym)) | |
cd9d95d7 | 236 | (or (assq-ref (ghil-mod-table mod) sym) |
6167de4f | 237 | (let ((var (make-ghil-var (make-ghil-env mod) sym 'module))) |
cd9d95d7 AW |
238 | (apush! sym var (ghil-mod-table mod)) |
239 | var))) | |
240 | ||
77046be3 | 241 | (define (call-with-ghil-environment e syms func) |
cb4cca12 KN |
242 | (let* ((e (make-ghil-env e)) |
243 | (vars (map (lambda (s) | |
244 | (let ((v (make-ghil-var e s 'argument))) | |
245 | (ghil-env-add! e v) v)) | |
246 | syms))) | |
247 | (func e vars))) | |
248 | ||
77046be3 | 249 | (define (call-with-ghil-bindings e syms func) |
cb4cca12 KN |
250 | (let* ((vars (map (lambda (s) |
251 | (let ((v (make-ghil-var e s 'local))) | |
252 | (ghil-env-add! e v) v)) | |
253 | syms)) | |
254 | (ret (func vars))) | |
255 | (for-each (lambda (v) (ghil-env-remove! e v)) vars) | |
256 | ret)) | |
257 | ||
17e90c5e KN |
258 | \f |
259 | ;;; | |
260 | ;;; Parser | |
261 | ;;; | |
262 | ||
ac99cb0c KN |
263 | ;;; (define-public (parse-ghil x e) |
264 | ;;; (parse `(@lambda () ,x) (make-ghil-mod e))) | |
265 | ;;; | |
266 | ;;; (define (parse x e) | |
267 | ;;; (cond ((pair? x) (parse-pair x e)) | |
268 | ;;; ((symbol? x) | |
269 | ;;; (let ((str (symbol->string x))) | |
270 | ;;; (case (string-ref str 0) | |
271 | ;;; ((#\@) (error "Invalid use of IL primitive" x)) | |
272 | ;;; ((#\:) (let ((sym (string->symbol (substring str 1)))) | |
273 | ;;; (<ghil-quote> (symbol->keyword sym)))) | |
274 | ;;; (else (<ghil-ref> e (ghil-lookup e x)))))) | |
275 | ;;; (else (<ghil-quote> x)))) | |
276 | ;;; | |
277 | ;;; (define (map-parse x e) | |
278 | ;;; (map (lambda (x) (parse x e)) x)) | |
279 | ;;; | |
280 | ;;; (define (parse-pair x e) | |
281 | ;;; (let ((head (car x)) (tail (cdr x))) | |
282 | ;;; (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@)) | |
283 | ;;; (if (ghil-primitive-macro? head) | |
284 | ;;; (parse (apply (ghil-macro-expander head) tail) e) | |
285 | ;;; (parse-primitive head tail e)) | |
286 | ;;; (<ghil-call> e (parse head e) (map-parse tail e))))) | |
287 | ;;; | |
288 | ;;; (define (parse-primitive prim args e) | |
289 | ;;; (case prim | |
290 | ;;; ;; (@ IDENTIFIER) | |
291 | ;;; ((@) | |
292 | ;;; (match args | |
293 | ;;; (() | |
294 | ;;; (<ghil-ref> e (make-ghil-var '@ '@ 'module))) | |
295 | ;;; ((identifier) | |
296 | ;;; (receive (module name) (identifier-split identifier) | |
297 | ;;; (<ghil-ref> e (make-ghil-var module name 'module)))))) | |
298 | ;;; | |
299 | ;;; ;; (@@ OP ARGS...) | |
300 | ;;; ((@@) | |
301 | ;;; (match args | |
302 | ;;; ((op . args) | |
303 | ;;; (<ghil-inline> op (map-parse args e))))) | |
304 | ;;; | |
305 | ;;; ;; (@void) | |
306 | ;;; ((@void) | |
307 | ;;; (match args | |
308 | ;;; (() (<ghil-void>)))) | |
309 | ;;; | |
310 | ;;; ;; (@quote OBJ) | |
311 | ;;; ((@quote) | |
312 | ;;; (match args | |
313 | ;;; ((obj) | |
314 | ;;; (<ghil-quote> obj)))) | |
315 | ;;; | |
316 | ;;; ;; (@define NAME VAL) | |
317 | ;;; ((@define) | |
318 | ;;; (match args | |
319 | ;;; ((name val) | |
320 | ;;; (let ((v (ghil-lookup e name))) | |
321 | ;;; (<ghil-set> e v (parse val e)))))) | |
322 | ;;; | |
323 | ;;; ;; (@set! NAME VAL) | |
324 | ;;; ((@set!) | |
325 | ;;; (match args | |
326 | ;;; ((name val) | |
327 | ;;; (let ((v (ghil-lookup e name))) | |
328 | ;;; (<ghil-set> e v (parse val e)))))) | |
329 | ;;; | |
330 | ;;; ;; (@if TEST THEN [ELSE]) | |
331 | ;;; ((@if) | |
332 | ;;; (match args | |
333 | ;;; ((test then) | |
334 | ;;; (<ghil-if> (parse test e) (parse then e) (<ghil-void>))) | |
335 | ;;; ((test then else) | |
336 | ;;; (<ghil-if> (parse test e) (parse then e) (parse else e))))) | |
337 | ;;; | |
338 | ;;; ;; (@begin BODY...) | |
339 | ;;; ((@begin) | |
340 | ;;; (parse-body args e)) | |
341 | ;;; | |
342 | ;;; ;; (@let ((SYM INIT)...) BODY...) | |
343 | ;;; ((@let) | |
344 | ;;; (match args | |
345 | ;;; ((((sym init) ...) body ...) | |
346 | ;;; (let* ((vals (map-parse init e)) | |
347 | ;;; (vars (map (lambda (s) | |
348 | ;;; (let ((v (make-ghil-var e s 'local))) | |
349 | ;;; (ghil-env-add! e v) v)) | |
350 | ;;; sym)) | |
351 | ;;; (body (parse-body body e))) | |
352 | ;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars) | |
353 | ;;; (<ghil-bind> e vars vals body))))) | |
354 | ;;; | |
355 | ;;; ;; (@letrec ((SYM INIT)...) BODY...) | |
356 | ;;; ((@letrec) | |
357 | ;;; (match args | |
358 | ;;; ((((sym init) ...) body ...) | |
359 | ;;; (let* ((vars (map (lambda (s) | |
360 | ;;; (let ((v (make-ghil-var e s 'local))) | |
361 | ;;; (ghil-env-add! e v) v)) | |
362 | ;;; sym)) | |
363 | ;;; (vals (map-parse init e)) | |
364 | ;;; (body (parse-body body e))) | |
365 | ;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars) | |
366 | ;;; (<ghil-bind> e vars vals body))))) | |
367 | ;;; | |
368 | ;;; ;; (@lambda FORMALS BODY...) | |
369 | ;;; ((@lambda) | |
370 | ;;; (match args | |
371 | ;;; ((formals . body) | |
372 | ;;; (receive (syms rest) (parse-formals formals) | |
373 | ;;; (let* ((e (make-ghil-env e)) | |
374 | ;;; (vars (map (lambda (s) | |
375 | ;;; (let ((v (make-ghil-var e s 'argument))) | |
376 | ;;; (ghil-env-add! e v) v)) | |
377 | ;;; syms))) | |
378 | ;;; (<ghil-lambda> e vars rest (parse-body body e))))))) | |
379 | ;;; | |
380 | ;;; ;; (@eval-case CLAUSE...) | |
381 | ;;; ((@eval-case) | |
382 | ;;; (let loop ((clauses args)) | |
383 | ;;; (cond ((null? clauses) (<ghil-void>)) | |
384 | ;;; ((or (eq? (caar clauses) '@else) | |
385 | ;;; (and (memq 'load-toplevel (caar clauses)) | |
386 | ;;; (ghil-env-toplevel? e))) | |
387 | ;;; (parse-body (cdar clauses) e)) | |
388 | ;;; (else | |
389 | ;;; (loop (cdr clauses)))))) | |
390 | ;;; | |
391 | ;;; (else (error "Unknown primitive:" prim)))) | |
392 | ;;; | |
393 | ;;; (define (parse-body x e) | |
394 | ;;; (<ghil-begin> (map-parse x e))) | |
395 | ;;; | |
396 | ;;; (define (parse-formals formals) | |
397 | ;;; (cond | |
398 | ;;; ;; (@lambda x ...) | |
399 | ;;; ((symbol? formals) (values (list formals) #t)) | |
400 | ;;; ;; (@lambda (x y z) ...) | |
401 | ;;; ((list? formals) (values formals #f)) | |
402 | ;;; ;; (@lambda (x y . z) ...) | |
403 | ;;; ((pair? formals) | |
404 | ;;; (let loop ((l formals) (v '())) | |
405 | ;;; (if (pair? l) | |
406 | ;;; (loop (cdr l) (cons (car l) v)) | |
407 | ;;; (values (reverse! (cons l v)) #t)))) | |
408 | ;;; (else (error "Invalid formals:" formals)))) | |
409 | ;;; | |
410 | ;;; (define (identifier-split identifier) | |
411 | ;;; (let ((m (string-match "::([^:]*)$" (symbol->string identifier)))) | |
412 | ;;; (if m | |
413 | ;;; (values (string->symbol (match:prefix m)) | |
414 | ;;; (string->symbol (match:substring m 1))) | |
415 | ;;; (values #f identifier)))) |