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 | |
ac99cb0c | 26 | ( |
849cefac | 27 | <ghil-void> make-ghil-void <ghil-void>? <ghil-void>-1 <ghil-void>-2 |
bdaffda2 | 28 | ghil-void-env ghil-void-loc |
849cefac | 29 | <ghil-quote> make-ghil-quote <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3 |
bdaffda2 | 30 | ghil-quote-env ghil-quote-loc ghil-quote-obj |
849cefac | 31 | <ghil-quasiquote> make-ghil-quasiquote <ghil-quasiquote>? |
cb4cca12 | 32 | <ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3 |
bdaffda2 | 33 | ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp |
849cefac | 34 | <ghil-unquote> make-ghil-unquote <ghil-unquote>? |
cb4cca12 | 35 | <ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3 |
bdaffda2 | 36 | ghil-unquote-env ghil-unquote-loc ghil-unquote-exp |
849cefac | 37 | <ghil-unquote-splicing> make-ghil-unquote-splicing <ghil-unquote-splicing>? |
cb4cca12 KN |
38 | <ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2 |
39 | <ghil-unquote-splicing>-3 | |
bdaffda2 | 40 | ghil-unquote-env ghil-unquote-loc ghil-unquote-exp |
cb4cca12 | 41 | |
849cefac | 42 | <ghil-ref> make-ghil-ref <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3 |
bdaffda2 | 43 | ghil-ref-env ghil-ref-loc ghil-ref-var |
849cefac | 44 | <ghil-set> make-ghil-set <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4 |
bdaffda2 | 45 | ghil-set-env ghil-set-loc ghil-set-var ghil-set-val |
849cefac | 46 | <ghil-define> make-ghil-define <ghil-define>? |
cb4cca12 | 47 | <ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4 |
bdaffda2 | 48 | ghil-define-env ghil-define-loc ghil-define-var ghil-define-val |
cb4cca12 | 49 | |
849cefac | 50 | <ghil-if> make-ghil-if <ghil-if>? |
cb4cca12 | 51 | <ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5 |
bdaffda2 | 52 | ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else |
849cefac | 53 | <ghil-and> make-ghil-and <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3 |
bdaffda2 | 54 | ghil-and-env ghil-and-loc ghil-and-exps |
849cefac | 55 | <ghil-or> make-ghil-or <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3 |
bdaffda2 | 56 | ghil-or-env ghil-or-loc ghil-or-exps |
849cefac | 57 | <ghil-begin> make-ghil-begin <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3 |
bdaffda2 | 58 | ghil-begin-env ghil-begin-loc ghil-begin-exps |
849cefac | 59 | <ghil-bind> make-ghil-bind <ghil-bind>? |
cb4cca12 | 60 | <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5 |
bdaffda2 | 61 | ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body |
849cefac | 62 | <ghil-lambda> make-ghil-lambda <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2 |
cb4cca12 | 63 | <ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5 |
bdaffda2 | 64 | ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body |
849cefac | 65 | <ghil-inline> make-ghil-inline <ghil-inline>? |
cb4cca12 | 66 | <ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4 |
bdaffda2 | 67 | ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args |
849cefac | 68 | <ghil-call> make-ghil-call <ghil-call>? |
cb4cca12 | 69 | <ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4 |
bdaffda2 | 70 | ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args |
aa0a011b AW |
71 | |
72 | <ghil-var> make-ghil-var ghil-var-env ghil-var-name ghil-var-kind | |
73 | ghil-var-type ghil-var-value ghil-var-index | |
74 | ||
75 | <ghil-mod> make-ghil-mod ghil-mod-module ghil-mod-table ghil-mod-imports | |
76 | ||
77 | <ghil-env> make-ghil-env ghil-env-mod ghil-env-parent ghil-env-table | |
78 | ghil-env-variables)) | |
17e90c5e KN |
79 | |
80 | \f | |
81 | ;;; | |
82 | ;;; Parse tree | |
83 | ;;; | |
84 | ||
ac99cb0c KN |
85 | (define-type <ghil> |
86 | (| | |
87 | ;; Objects | |
88 | (<ghil-void> env loc) | |
89 | (<ghil-quote> env loc obj) | |
90 | (<ghil-quasiquote> env loc exp) | |
91 | (<ghil-unquote> env loc exp) | |
92 | (<ghil-unquote-splicing> env loc exp) | |
93 | ;; Variables | |
94 | (<ghil-ref> env loc var) | |
95 | (<ghil-set> env loc var val) | |
96 | (<ghil-define> env loc var val) | |
97 | ;; Controls | |
98 | (<ghil-if> env loc test then else) | |
99 | (<ghil-and> env loc exps) | |
100 | (<ghil-or> env loc exps) | |
101 | (<ghil-begin> env loc exps) | |
102 | (<ghil-bind> env loc vars vals body) | |
103 | (<ghil-lambda> env loc vars rest body) | |
104 | (<ghil-call> env loc proc args) | |
105 | (<ghil-inline> env loc inline args))) | |
106 | ||
107 | (define-public ghil-env %slot-1) | |
108 | (define-public ghil-loc %slot-2) | |
17e90c5e KN |
109 | |
110 | \f | |
46cd9a34 KN |
111 | ;;; |
112 | ;;; Procedures | |
113 | ;;; | |
114 | ||
115 | (define *core-primitives* | |
116 | '(@void @quote @define @set! @if @begin @let @letrec @lambda)) | |
117 | ||
118 | (define *macro-module* (resolve-module '(system il macros))) | |
119 | ||
ac99cb0c | 120 | (define-public (ghil-primitive-macro? x) |
25ec54b5 KN |
121 | (and (module-defined? *macro-module* x) |
122 | (procedure? (module-ref *macro-module* x)))) | |
46cd9a34 KN |
123 | |
124 | (define (ghil-macro-expander x) | |
125 | (module-ref *macro-module* x)) | |
126 | ||
127 | (define (ghil-primitive? x) | |
128 | (or (memq x *core-primitives*) | |
129 | (ghil-primitive-macro? x))) | |
130 | ||
131 | \f | |
17e90c5e KN |
132 | ;;; |
133 | ;;; Variables | |
134 | ;;; | |
135 | ||
ac99cb0c | 136 | (define-record (<ghil-var> env name kind (type #f) (value #f) (index #f))) |
849cefac | 137 | (export make-ghil-var) |
cb4cca12 | 138 | |
17e90c5e KN |
139 | \f |
140 | ;;; | |
141 | ;;; Modules | |
142 | ;;; | |
143 | ||
ac99cb0c | 144 | (define-record (<ghil-mod> module (table '()) (imports '()))) |
849cefac | 145 | (export make-ghil-mod) |
17e90c5e KN |
146 | |
147 | \f | |
148 | ;;; | |
149 | ;;; Environments | |
150 | ;;; | |
151 | ||
ac99cb0c | 152 | (define-record (<ghil-env> mod parent (table '()) (variables '()))) |
17e90c5e | 153 | |
849cefac | 154 | (define %make-ghil-env make-ghil-env) |
ac99cb0c | 155 | (define-public (make-ghil-env e) |
849cefac AW |
156 | (record-case e |
157 | ((<ghil-mod>) (%make-ghil-env :mod e :parent e)) | |
158 | ((<ghil-env> m) (%make-ghil-env :mod m :parent e)))) | |
17e90c5e | 159 | |
66292535 | 160 | (define (ghil-env-toplevel? e) |
61dc81d9 | 161 | (eq? (ghil-env-mod e) (gil-env-parent e))) |
66292535 | 162 | |
ac99cb0c | 163 | (define (ghil-env-ref env sym) |
61dc81d9 AW |
164 | (assq-ref (ghil-env-table env) sym)) |
165 | ||
166 | (define-macro (push! item loc) | |
167 | `(set! ,loc (cons ,item ,loc))) | |
168 | (define-macro (apush! k v loc) | |
169 | `(set! ,loc (acons ,k ,v ,loc))) | |
170 | (define-macro (apopq! k loc) | |
171 | `(set! ,loc (assq-remove! ,k ,loc))) | |
17e90c5e | 172 | |
ac99cb0c | 173 | (define-public (ghil-env-add! env var) |
61dc81d9 AW |
174 | (apush! (ghil-var-name var) var (ghil-env-table env)) |
175 | (push! var (ghil-env-variables env))) | |
17e90c5e | 176 | |
ac99cb0c | 177 | (define (ghil-env-remove! env var) |
61dc81d9 | 178 | (apopq! (ghil-var-name var) (ghil-env-table env))) |
17e90c5e | 179 | |
ac99cb0c KN |
180 | \f |
181 | ;;; | |
182 | ;;; Public interface | |
183 | ;;; | |
184 | ||
61dc81d9 | 185 | ;; looking up a var has side effects? |
ac99cb0c | 186 | (define-public (ghil-lookup env sym) |
17e90c5e | 187 | (or (ghil-env-ref env sym) |
61dc81d9 AW |
188 | (let loop ((e (ghil-env-parent env))) |
189 | (record-case e | |
190 | ((<ghil-mod> module table imports) | |
191 | (or (assq-ref table sym) | |
192 | (let ((var (make-ghil-var #f sym 'module))) | |
193 | (apush! sym var (ghil-mod-table e)) | |
194 | var))) | |
195 | ((<ghil-env> mod parent table variables) | |
196 | (let ((found (assq-ref table sym))) | |
197 | (if found | |
198 | (begin (set! (ghil-var-kind found) 'external) found) | |
199 | (loop parent)))))))) | |
17e90c5e | 200 | |
cb4cca12 KN |
201 | (define-public (call-with-ghil-environment e syms func) |
202 | (let* ((e (make-ghil-env e)) | |
203 | (vars (map (lambda (s) | |
204 | (let ((v (make-ghil-var e s 'argument))) | |
205 | (ghil-env-add! e v) v)) | |
206 | syms))) | |
207 | (func e vars))) | |
208 | ||
209 | (define-public (call-with-ghil-bindings e syms func) | |
210 | (let* ((vars (map (lambda (s) | |
211 | (let ((v (make-ghil-var e s 'local))) | |
212 | (ghil-env-add! e v) v)) | |
213 | syms)) | |
214 | (ret (func vars))) | |
215 | (for-each (lambda (v) (ghil-env-remove! e v)) vars) | |
216 | ret)) | |
217 | ||
17e90c5e KN |
218 | \f |
219 | ;;; | |
220 | ;;; Parser | |
221 | ;;; | |
222 | ||
ac99cb0c KN |
223 | ;;; (define-public (parse-ghil x e) |
224 | ;;; (parse `(@lambda () ,x) (make-ghil-mod e))) | |
225 | ;;; | |
226 | ;;; (define (parse x e) | |
227 | ;;; (cond ((pair? x) (parse-pair x e)) | |
228 | ;;; ((symbol? x) | |
229 | ;;; (let ((str (symbol->string x))) | |
230 | ;;; (case (string-ref str 0) | |
231 | ;;; ((#\@) (error "Invalid use of IL primitive" x)) | |
232 | ;;; ((#\:) (let ((sym (string->symbol (substring str 1)))) | |
233 | ;;; (<ghil-quote> (symbol->keyword sym)))) | |
234 | ;;; (else (<ghil-ref> e (ghil-lookup e x)))))) | |
235 | ;;; (else (<ghil-quote> x)))) | |
236 | ;;; | |
237 | ;;; (define (map-parse x e) | |
238 | ;;; (map (lambda (x) (parse x e)) x)) | |
239 | ;;; | |
240 | ;;; (define (parse-pair x e) | |
241 | ;;; (let ((head (car x)) (tail (cdr x))) | |
242 | ;;; (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@)) | |
243 | ;;; (if (ghil-primitive-macro? head) | |
244 | ;;; (parse (apply (ghil-macro-expander head) tail) e) | |
245 | ;;; (parse-primitive head tail e)) | |
246 | ;;; (<ghil-call> e (parse head e) (map-parse tail e))))) | |
247 | ;;; | |
248 | ;;; (define (parse-primitive prim args e) | |
249 | ;;; (case prim | |
250 | ;;; ;; (@ IDENTIFIER) | |
251 | ;;; ((@) | |
252 | ;;; (match args | |
253 | ;;; (() | |
254 | ;;; (<ghil-ref> e (make-ghil-var '@ '@ 'module))) | |
255 | ;;; ((identifier) | |
256 | ;;; (receive (module name) (identifier-split identifier) | |
257 | ;;; (<ghil-ref> e (make-ghil-var module name 'module)))))) | |
258 | ;;; | |
259 | ;;; ;; (@@ OP ARGS...) | |
260 | ;;; ((@@) | |
261 | ;;; (match args | |
262 | ;;; ((op . args) | |
263 | ;;; (<ghil-inline> op (map-parse args e))))) | |
264 | ;;; | |
265 | ;;; ;; (@void) | |
266 | ;;; ((@void) | |
267 | ;;; (match args | |
268 | ;;; (() (<ghil-void>)))) | |
269 | ;;; | |
270 | ;;; ;; (@quote OBJ) | |
271 | ;;; ((@quote) | |
272 | ;;; (match args | |
273 | ;;; ((obj) | |
274 | ;;; (<ghil-quote> obj)))) | |
275 | ;;; | |
276 | ;;; ;; (@define NAME VAL) | |
277 | ;;; ((@define) | |
278 | ;;; (match args | |
279 | ;;; ((name val) | |
280 | ;;; (let ((v (ghil-lookup e name))) | |
281 | ;;; (<ghil-set> e v (parse val e)))))) | |
282 | ;;; | |
283 | ;;; ;; (@set! NAME VAL) | |
284 | ;;; ((@set!) | |
285 | ;;; (match args | |
286 | ;;; ((name val) | |
287 | ;;; (let ((v (ghil-lookup e name))) | |
288 | ;;; (<ghil-set> e v (parse val e)))))) | |
289 | ;;; | |
290 | ;;; ;; (@if TEST THEN [ELSE]) | |
291 | ;;; ((@if) | |
292 | ;;; (match args | |
293 | ;;; ((test then) | |
294 | ;;; (<ghil-if> (parse test e) (parse then e) (<ghil-void>))) | |
295 | ;;; ((test then else) | |
296 | ;;; (<ghil-if> (parse test e) (parse then e) (parse else e))))) | |
297 | ;;; | |
298 | ;;; ;; (@begin BODY...) | |
299 | ;;; ((@begin) | |
300 | ;;; (parse-body args e)) | |
301 | ;;; | |
302 | ;;; ;; (@let ((SYM INIT)...) BODY...) | |
303 | ;;; ((@let) | |
304 | ;;; (match args | |
305 | ;;; ((((sym init) ...) body ...) | |
306 | ;;; (let* ((vals (map-parse init e)) | |
307 | ;;; (vars (map (lambda (s) | |
308 | ;;; (let ((v (make-ghil-var e s 'local))) | |
309 | ;;; (ghil-env-add! e v) v)) | |
310 | ;;; sym)) | |
311 | ;;; (body (parse-body body e))) | |
312 | ;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars) | |
313 | ;;; (<ghil-bind> e vars vals body))))) | |
314 | ;;; | |
315 | ;;; ;; (@letrec ((SYM INIT)...) BODY...) | |
316 | ;;; ((@letrec) | |
317 | ;;; (match args | |
318 | ;;; ((((sym init) ...) body ...) | |
319 | ;;; (let* ((vars (map (lambda (s) | |
320 | ;;; (let ((v (make-ghil-var e s 'local))) | |
321 | ;;; (ghil-env-add! e v) v)) | |
322 | ;;; sym)) | |
323 | ;;; (vals (map-parse init e)) | |
324 | ;;; (body (parse-body body e))) | |
325 | ;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars) | |
326 | ;;; (<ghil-bind> e vars vals body))))) | |
327 | ;;; | |
328 | ;;; ;; (@lambda FORMALS BODY...) | |
329 | ;;; ((@lambda) | |
330 | ;;; (match args | |
331 | ;;; ((formals . body) | |
332 | ;;; (receive (syms rest) (parse-formals formals) | |
333 | ;;; (let* ((e (make-ghil-env e)) | |
334 | ;;; (vars (map (lambda (s) | |
335 | ;;; (let ((v (make-ghil-var e s 'argument))) | |
336 | ;;; (ghil-env-add! e v) v)) | |
337 | ;;; syms))) | |
338 | ;;; (<ghil-lambda> e vars rest (parse-body body e))))))) | |
339 | ;;; | |
340 | ;;; ;; (@eval-case CLAUSE...) | |
341 | ;;; ((@eval-case) | |
342 | ;;; (let loop ((clauses args)) | |
343 | ;;; (cond ((null? clauses) (<ghil-void>)) | |
344 | ;;; ((or (eq? (caar clauses) '@else) | |
345 | ;;; (and (memq 'load-toplevel (caar clauses)) | |
346 | ;;; (ghil-env-toplevel? e))) | |
347 | ;;; (parse-body (cdar clauses) e)) | |
348 | ;;; (else | |
349 | ;;; (loop (cdr clauses)))))) | |
350 | ;;; | |
351 | ;;; (else (error "Unknown primitive:" prim)))) | |
352 | ;;; | |
353 | ;;; (define (parse-body x e) | |
354 | ;;; (<ghil-begin> (map-parse x e))) | |
355 | ;;; | |
356 | ;;; (define (parse-formals formals) | |
357 | ;;; (cond | |
358 | ;;; ;; (@lambda x ...) | |
359 | ;;; ((symbol? formals) (values (list formals) #t)) | |
360 | ;;; ;; (@lambda (x y z) ...) | |
361 | ;;; ((list? formals) (values formals #f)) | |
362 | ;;; ;; (@lambda (x y . z) ...) | |
363 | ;;; ((pair? formals) | |
364 | ;;; (let loop ((l formals) (v '())) | |
365 | ;;; (if (pair? l) | |
366 | ;;; (loop (cdr l) (cons (car l) v)) | |
367 | ;;; (values (reverse! (cons l v)) #t)))) | |
368 | ;;; (else (error "Invalid formals:" formals)))) | |
369 | ;;; | |
370 | ;;; (define (identifier-split identifier) | |
371 | ;;; (let ((m (string-match "::([^:]*)$" (symbol->string identifier)))) | |
372 | ;;; (if m | |
373 | ;;; (values (string->symbol (match:prefix m)) | |
374 | ;;; (string->symbol (match:substring m 1))) | |
375 | ;;; (values #f identifier)))) |