Commit | Line | Data |
---|---|---|
51248e6e DK |
1 | ;;; Guile Emac Lisp |
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 (language elisp compile-tree-il) | |
23 | #:use-module (language tree-il) | |
24 | #:use-module (system base pmatch) | |
25 | #:export (compile-tree-il)) | |
26 | ||
27 | ||
28 | ; Find the source properties of some parsed expression if there are any | |
29 | ; associated with it. | |
30 | ||
31 | (define (location x) | |
32 | (and (pair? x) | |
33 | (let ((props (source-properties x))) | |
34 | (and (not (null? props)) | |
35 | props)))) | |
36 | ||
37 | ||
fdfb36de | 38 | ; Value to use for Elisp's nil and t. |
4530432e | 39 | |
a4316739 | 40 | (define (nil-value loc) (make-const loc #f)) |
fdfb36de | 41 | (define (t-value loc) (make-const loc #t)) |
4530432e DK |
42 | |
43 | ||
344927c3 DK |
44 | ; Modules that contain the value and function slot bindings. |
45 | ||
46 | (define runtime '(language elisp runtime)) | |
47 | (define value-slot '(language elisp runtime value-slot)) | |
48 | (define function-slot '(language elisp runtime function-slot)) | |
49 | ||
50 | ||
50abfe76 DK |
51 | ; Build a call to a primitive procedure nicely. |
52 | ||
53 | (define (call-primitive loc sym . args) | |
54 | (make-application loc (make-primitive-ref loc sym) args)) | |
55 | ||
56 | ||
57 | ; Error reporting routine for syntax/compilation problems or build code for | |
58 | ; a runtime-error output. | |
344927c3 DK |
59 | |
60 | (define (report-error loc . args) | |
61 | (apply error args)) | |
62 | ||
50abfe76 DK |
63 | (define (runtime-error loc msg . args) |
64 | (make-application loc (make-primitive-ref loc 'error) | |
65 | (cons (make-const loc msg) args))) | |
66 | ||
344927c3 DK |
67 | |
68 | ; Generate code to ensure a fluid is there for further use of a given symbol. | |
cef997e8 DK |
69 | ; ensure-fluids-for does the same for a list of symbols and builds a sequence |
70 | ; that executes the fluid-insurances first, followed by all body commands; this | |
71 | ; is a routine for convenience (needed with let, let*, lambda). | |
344927c3 DK |
72 | |
73 | (define (ensure-fluid! loc sym module) | |
f28de791 DK |
74 | (let ((resolved-module (call-primitive loc 'resolve-module |
75 | (make-const loc module)))) | |
76 | (make-conditional loc | |
77 | (call-primitive loc 'module-defined? resolved-module (make-const loc sym)) | |
78 | (make-void loc) | |
79 | (make-sequence loc | |
80 | (list (call-primitive loc 'module-define! | |
81 | resolved-module (make-const loc sym) | |
82 | (call-primitive loc 'make-fluid)) | |
83 | (call-primitive loc 'module-export! | |
84 | resolved-module | |
85 | (call-primitive loc 'list (make-const loc sym)))))))) | |
86 | ||
344927c3 | 87 | |
cef997e8 DK |
88 | (define (ensure-fluids-for loc syms module . body) |
89 | (make-sequence loc | |
90 | `(,@(map (lambda (sym) (ensure-fluid! loc sym module)) syms) | |
91 | ,@body))) | |
92 | ||
344927c3 DK |
93 | |
94 | ; Generate code to reference a fluid saved variable. | |
95 | ||
96 | (define (reference-variable loc sym module) | |
97 | (make-sequence loc | |
98 | (list (ensure-fluid! loc sym module) | |
50abfe76 DK |
99 | (call-primitive loc 'fluid-ref |
100 | (make-module-ref loc module sym #t))))) | |
344927c3 DK |
101 | |
102 | ||
103 | ; Reference a variable and error if the value is void. | |
104 | ||
105 | (define (reference-with-check loc sym module) | |
106 | (let ((var (gensym))) | |
107 | (make-let loc '(value) `(,var) `(,(reference-variable loc sym module)) | |
108 | (make-conditional loc | |
50abfe76 DK |
109 | (call-primitive loc 'eq? |
110 | (make-module-ref loc runtime 'void #t) | |
111 | (make-lexical-ref loc 'value var)) | |
112 | (runtime-error loc "variable is void:" (make-const loc sym)) | |
344927c3 DK |
113 | (make-lexical-ref loc 'value var))))) |
114 | ||
115 | ||
116 | ; Generate code to set a fluid saved variable. | |
117 | ||
118 | (define (set-variable! loc sym module value) | |
119 | (make-sequence loc | |
120 | (list (ensure-fluid! loc sym module) | |
50abfe76 DK |
121 | (call-primitive loc 'fluid-set! |
122 | (make-module-ref loc module sym #t) | |
123 | value)))) | |
344927c3 DK |
124 | |
125 | ||
3a4b8635 DK |
126 | ; Process the bindings part of a let or let* expression; that is, check for |
127 | ; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...). | |
128 | ||
129 | (define (process-let-bindings loc bindings) | |
130 | (map (lambda (b) | |
131 | (if (symbol? b) | |
132 | (cons b 'nil) | |
133 | (if (or (not (list? b)) | |
134 | (not (= (length b) 2))) | |
135 | (report-error loc "expected symbol or list of 2 elements in let") | |
136 | (if (not (symbol? (car b))) | |
137 | (report-error loc "expected symbol in let") | |
138 | (cons (car b) (cadr b)))))) | |
139 | bindings)) | |
140 | ||
141 | ||
50abfe76 DK |
142 | ; Split the argument list of a lambda expression into required, optional and |
143 | ; rest arguments and also check it is actually valid. | |
144 | ||
145 | (define (split-lambda-arguments loc args) | |
146 | (let iterate ((tail args) | |
147 | (mode 'required) | |
148 | (required '()) | |
149 | (optional '())) | |
150 | (cond | |
151 | ||
152 | ((null? tail) | |
153 | (values (reverse required) (reverse optional) #f)) | |
154 | ||
155 | ((and (eq? mode 'required) | |
156 | (eq? (car tail) '&optional)) | |
157 | (iterate (cdr tail) 'optional required optional)) | |
158 | ||
159 | ((eq? (car tail) '&rest) | |
160 | (if (or (null? (cdr tail)) | |
161 | (not (null? (cddr tail)))) | |
162 | (report-error loc "expected exactly one symbol after &rest") | |
163 | (values (reverse required) (reverse optional) (cadr tail)))) | |
164 | ||
165 | (else | |
166 | (if (not (symbol? (car tail))) | |
167 | (report-error loc "expected symbol in argument list, got" (car tail)) | |
168 | (case mode | |
169 | ((required) (iterate (cdr tail) mode | |
170 | (cons (car tail) required) optional)) | |
171 | ((optional) (iterate (cdr tail) mode | |
172 | required (cons (car tail) optional))) | |
173 | ((else) (error "invalid mode in split-lambda-arguments" mode)))))))) | |
174 | ||
175 | ||
176 | ; Compile a lambda expression. Things get a little complicated because TreeIL | |
177 | ; does not allow optional arguments but only one rest argument, and also the | |
178 | ; rest argument should be nil instead of '() for no values given. Because of | |
179 | ; this, we have to do a little preprocessing to get everything done before the | |
180 | ; real body is called. | |
181 | ; | |
182 | ; (lambda (a &optional b &rest c) body) should become: | |
183 | ; (lambda (a_ . rest_) | |
184 | ; (with-fluids* (list a b c) (list a_ nil nil) | |
185 | ; (lambda () | |
186 | ; (if (not (null? rest_)) | |
187 | ; (begin | |
188 | ; (fluid-set! b (car rest_)) | |
189 | ; (set! rest_ (cdr rest_)) | |
190 | ; (if (not (null? rest_)) | |
191 | ; (fluid-set! c rest_)))) | |
192 | ; body))) | |
193 | ; | |
194 | ; This is formulated quite imperatively, but I think in this case that is quite | |
195 | ; clear and better than creating a lot of nested let's. | |
196 | ||
197 | (define (compile-lambda loc args body) | |
198 | (call-with-values | |
199 | (lambda () | |
200 | (split-lambda-arguments loc args)) | |
201 | (lambda (required optional rest) | |
50abfe76 DK |
202 | (let ((required-sym (map (lambda (sym) (gensym)) required)) |
203 | (rest-sym (if (or rest (not (null? optional))) (gensym) '()))) | |
cef997e8 DK |
204 | (let ((real-args (append required-sym rest-sym)) |
205 | (locals `(,@required ,@optional ,@(if rest (list rest) '())))) | |
206 | (make-lambda loc | |
207 | real-args real-args '() | |
208 | (ensure-fluids-for loc locals value-slot | |
209 | (call-primitive loc 'with-fluids* | |
210 | (make-application loc (make-primitive-ref loc 'list) | |
211 | (map (lambda (sym) (make-module-ref loc value-slot sym #t)) | |
212 | locals)) | |
213 | (make-application loc (make-primitive-ref loc 'list) | |
214 | (append (map (lambda (sym) (make-lexical-ref loc sym sym)) | |
215 | required-sym) | |
216 | (map (lambda (sym) (nil-value loc)) | |
217 | (if rest | |
218 | `(,@optional ,rest-sym) | |
219 | optional)))) | |
220 | (make-lambda loc '() '() '() | |
221 | (make-sequence loc | |
222 | `(,(process-optionals loc optional rest-sym) | |
223 | ,(process-rest loc rest rest-sym) | |
224 | ,@(map compile-expr body)))))))))))) | |
50abfe76 DK |
225 | |
226 | ; Build the code to handle setting of optional arguments that are present | |
227 | ; and updating the rest list. | |
228 | (define (process-optionals loc optional rest-sym) | |
229 | (let iterate ((tail optional)) | |
230 | (if (null? tail) | |
231 | (make-void loc) | |
232 | (make-conditional loc | |
233 | (call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym)) | |
234 | (make-void loc) | |
235 | (make-sequence loc | |
236 | (list (set-variable! loc (car tail) value-slot | |
237 | (call-primitive loc 'car | |
238 | (make-lexical-ref loc rest-sym rest-sym))) | |
239 | (make-lexical-set loc rest-sym rest-sym | |
240 | (call-primitive loc 'cdr | |
241 | (make-lexical-ref loc rest-sym rest-sym))) | |
242 | (iterate (cdr tail)))))))) | |
243 | ||
244 | ; This builds the code to set the rest variable to nil if it is empty. | |
245 | (define (process-rest loc rest rest-sym) | |
246 | (let ((rest-empty (call-primitive loc 'null? | |
247 | (make-lexical-ref loc rest-sym rest-sym)))) | |
248 | (cond | |
249 | (rest | |
250 | (make-conditional loc rest-empty | |
251 | (make-void loc) | |
252 | (set-variable! loc rest value-slot | |
253 | (make-lexical-ref loc rest-sym rest-sym)))) | |
254 | ((not (null? rest-sym)) | |
255 | (make-conditional loc rest-empty | |
256 | (make-void loc) | |
257 | (runtime-error loc "too many arguments and no rest argument"))) | |
258 | (else (make-void loc))))) | |
259 | ||
260 | ||
51248e6e DK |
261 | ; Compile a symbol expression. This is a variable reference or maybe some |
262 | ; special value like nil. | |
263 | ||
264 | (define (compile-symbol loc sym) | |
265 | (case sym | |
fdfb36de | 266 | ((nil) (nil-value loc)) |
fdfb36de | 267 | ((t) (t-value loc)) |
cef997e8 | 268 | (else (reference-with-check loc sym value-slot)))) |
51248e6e DK |
269 | |
270 | ||
271 | ; Compile a pair-expression (that is, any structure-like construct). | |
272 | ||
273 | (define (compile-pair loc expr) | |
274 | (pmatch expr | |
275 | ||
276 | ((progn . ,forms) | |
277 | (make-sequence loc (map compile-expr forms))) | |
278 | ||
279 | ((if ,condition ,ifclause) | |
280 | (make-conditional loc (compile-expr condition) | |
281 | (compile-expr ifclause) | |
4530432e | 282 | (nil-value loc))) |
51248e6e DK |
283 | ((if ,condition ,ifclause ,elseclause) |
284 | (make-conditional loc (compile-expr condition) | |
285 | (compile-expr ifclause) | |
286 | (compile-expr elseclause))) | |
287 | ((if ,condition ,ifclause . ,elses) | |
288 | (make-conditional loc (compile-expr condition) | |
289 | (compile-expr ifclause) | |
290 | (make-sequence loc (map compile-expr elses)))) | |
291 | ||
a4316739 DK |
292 | ; For (cond ...) forms, a special case is a (condition) clause without |
293 | ; body. In this case, the value of condition itself should be returned, | |
294 | ; and thus is saved in a local variable for testing and returning, if it | |
295 | ; is found true. | |
51248e6e DK |
296 | ((cond . ,clauses) (guard (and-map (lambda (el) |
297 | (and (list? el) (not (null? el)))) | |
298 | clauses)) | |
299 | (let iterate ((tail clauses)) | |
300 | (if (null? tail) | |
4530432e | 301 | (nil-value loc) |
51248e6e | 302 | (let ((cur (car tail))) |
a4316739 DK |
303 | (if (null? (cdr cur)) |
304 | (let ((var (gensym))) | |
305 | (make-let loc | |
306 | '(condition) `(,var) `(,(compile-expr (car cur))) | |
307 | (make-conditional loc | |
308 | (make-lexical-ref loc 'condition var) | |
309 | (make-lexical-ref loc 'condition var) | |
310 | (iterate (cdr tail))))) | |
311 | (make-conditional loc | |
312 | (compile-expr (car cur)) | |
313 | (make-sequence loc (map compile-expr (cdr cur))) | |
314 | (iterate (cdr tail)))))))) | |
51248e6e | 315 | |
fdfb36de | 316 | ((and) (t-value loc)) |
51248e6e DK |
317 | ((and . ,expressions) |
318 | (let iterate ((tail expressions)) | |
319 | (if (null? (cdr tail)) | |
320 | (compile-expr (car tail)) | |
321 | (make-conditional loc | |
322 | (compile-expr (car tail)) | |
323 | (iterate (cdr tail)) | |
4530432e | 324 | (nil-value loc))))) |
51248e6e | 325 | |
fdfb36de DK |
326 | ((or . ,expressions) |
327 | (let iterate ((tail expressions)) | |
328 | (if (null? tail) | |
329 | (nil-value loc) | |
330 | (let ((var (gensym))) | |
331 | (make-let loc | |
332 | '(condition) `(,var) `(,(compile-expr (car tail))) | |
333 | (make-conditional loc | |
334 | (make-lexical-ref loc 'condition var) | |
335 | (make-lexical-ref loc 'condition var) | |
336 | (iterate (cdr tail)))))))) | |
337 | ||
344927c3 DK |
338 | ; Build a set form for possibly multiple values. The code is not formulated |
339 | ; tail recursive because it is clearer this way and large lists of symbol | |
340 | ; expression pairs are very unlikely. | |
341 | ((setq . ,args) | |
342 | (make-sequence loc | |
343 | (let iterate ((tail args)) | |
344 | (if (null? tail) | |
345 | (list (make-void loc)) | |
346 | (let ((sym (car tail)) | |
347 | (tailtail (cdr tail))) | |
348 | (if (not (symbol? sym)) | |
349 | (report-error loc "expected symbol in setq") | |
350 | (if (null? tailtail) | |
351 | (report-error loc "missing value for symbol in setq" sym) | |
352 | (let* ((val (compile-expr (car tailtail))) | |
353 | (op (set-variable! loc sym value-slot val))) | |
354 | (cons op (iterate (cdr tailtail))))))))))) | |
355 | ||
3a4b8635 DK |
356 | ; Let is done with a single call to with-fluids* binding them locally to new |
357 | ; values. | |
358 | ((let ,bindings . ,body) (guard (and (list? bindings) | |
359 | (list? body) | |
360 | (not (null? bindings)) | |
361 | (not (null? body)))) | |
362 | (let ((bind (process-let-bindings loc bindings))) | |
f28de791 DK |
363 | (ensure-fluids-for loc (map car bind) value-slot |
364 | (call-primitive loc 'with-fluids* | |
365 | (make-application loc (make-primitive-ref loc 'list) | |
366 | (map (lambda (el) | |
367 | (make-module-ref loc value-slot (car el) #t)) | |
368 | bind)) | |
369 | (make-application loc (make-primitive-ref loc 'list) | |
370 | (map (lambda (el) | |
371 | (compile-expr (cdr el))) | |
372 | bind)) | |
373 | (make-lambda loc '() '() '() | |
374 | (make-sequence loc (map compile-expr body))))))) | |
3a4b8635 DK |
375 | |
376 | ; Let* is compiled to a cascaded set of with-fluid* for each binding in turn | |
377 | ; so that each one already sees the preceding bindings. | |
378 | ((let* ,bindings . ,body) (guard (and (list? bindings) | |
379 | (list? body) | |
380 | (not (null? bindings)) | |
381 | (not (null? body)))) | |
382 | (let ((bind (process-let-bindings loc bindings))) | |
f28de791 DK |
383 | (ensure-fluids-for loc (map car bind) value-slot |
384 | (let iterate ((tail bind)) | |
385 | (if (null? tail) | |
386 | (make-sequence loc (map compile-expr body)) | |
387 | (call-primitive loc 'with-fluid* | |
388 | (make-module-ref loc value-slot (caar tail) #t) | |
389 | (compile-expr (cdar tail)) | |
390 | (make-lambda loc '() '() '() (iterate (cdr tail))))))))) | |
3a4b8635 | 391 | |
d221c18b DK |
392 | ; A while construct is transformed into a tail-recursive loop like this: |
393 | ; (letrec ((iterate (lambda () | |
394 | ; (if condition | |
395 | ; (begin body | |
396 | ; (iterate)) | |
397 | ; %nil)))) | |
398 | ; (iterate)) | |
399 | ((while ,condition . ,body) | |
400 | (let* ((itersym (gensym)) | |
401 | (compiled-body (map compile-expr body)) | |
402 | (iter-call (make-application loc | |
403 | (make-lexical-ref loc 'iterate itersym) | |
404 | (list))) | |
405 | (full-body (make-sequence loc | |
cef997e8 | 406 | `(,@compiled-body ,iter-call))) |
d221c18b DK |
407 | (lambda-body (make-conditional loc |
408 | (compile-expr condition) | |
409 | full-body | |
410 | (nil-value loc))) | |
411 | (iter-thunk (make-lambda loc '() '() '() lambda-body))) | |
412 | (make-letrec loc '(iterate) (list itersym) (list iter-thunk) | |
413 | iter-call))) | |
414 | ||
50abfe76 DK |
415 | ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression |
416 | ; that should be compiled. | |
417 | ((lambda ,args . ,body) (guard (not (null? body))) | |
418 | (compile-lambda loc args body)) | |
419 | ((function (lambda ,args . ,body)) (guard (not (null? body))) | |
420 | (compile-lambda loc args body)) | |
421 | ||
cef997e8 DK |
422 | ; Function calls using (function args) standard notation; here, we have to |
423 | ; take the function value of a symbol if it is one. It seems that functions | |
424 | ; in form of uncompiled lists are not supported in this syntax, so we don't | |
425 | ; have to care for them. | |
426 | ((,func . ,args) | |
427 | (make-application loc | |
428 | (if (symbol? func) | |
429 | (reference-with-check loc func function-slot) | |
430 | (compile-expr func)) | |
431 | (map compile-expr args))) | |
432 | ||
51248e6e DK |
433 | (('quote ,val) |
434 | (make-const loc val)) | |
435 | ||
436 | (else | |
344927c3 | 437 | (report-error loc "unrecognized elisp" expr)))) |
51248e6e DK |
438 | |
439 | ||
440 | ; Compile a single expression to TreeIL. | |
441 | ||
442 | (define (compile-expr expr) | |
443 | (let ((loc (location expr))) | |
444 | (cond | |
445 | ((symbol? expr) | |
446 | (compile-symbol loc expr)) | |
447 | ((pair? expr) | |
448 | (compile-pair loc expr)) | |
449 | (else (make-const loc expr))))) | |
450 | ||
451 | ||
452 | ; Entry point for compilation to TreeIL. | |
453 | ||
454 | (define (compile-tree-il expr env opts) | |
455 | (values | |
456 | (compile-expr expr) | |
457 | env | |
458 | env)) |