3 ;; Copyright (C) 2009 Free Software Foundation, Inc.
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)
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.
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.
22 (define-module (language elisp compile-tree-il)
23 #:use-module (language elisp bindings)
24 #:use-module (language tree-il)
25 #:use-module (system base pmatch)
26 #:use-module (system base compile)
27 #:use-module (srfi srfi-1)
28 #:export (compile-tree-il))
31 ; Certain common parameters (like the bindings data structure or compiler
32 ; options) are not always passed around but accessed using fluids to simulate
33 ; dynamic binding (hey, this is about elisp).
35 ; The bindings data structure to keep track of symbol binding related data.
36 (define bindings-data (make-fluid))
38 ; Store for which symbols (or all/none) void checks are disabled.
39 (define disable-void-check (make-fluid))
41 ; Store which symbols (or all/none) should always be bound lexically, even
42 ; with ordinary let and as lambda arguments.
43 (define always-lexical (make-fluid))
46 ; Find the source properties of some parsed expression if there are any
51 (let ((props (source-properties x)))
52 (and (not (null? props))
56 ; Values to use for Elisp's nil and t.
58 (define (nil-value loc) (make-const loc (@ (language elisp runtime) nil-value)))
59 (define (t-value loc) (make-const loc (@ (language elisp runtime) t-value)))
62 ; Modules that contain the value and function slot bindings.
64 (define runtime '(language elisp runtime))
65 (define macro-slot '(language elisp runtime macro-slot))
66 (define value-slot (@ (language elisp runtime) value-slot-module))
67 (define function-slot (@ (language elisp runtime) function-slot-module))
70 ; The backquoting works the same as quasiquotes in Scheme, but the forms are
71 ; named differently; to make easy adaptions, we define these predicates checking
72 ; for a symbol being the car of an unquote/unquote-splicing/backquote form.
74 ; FIXME: Remove the quasiquote/unquote/unquote-splicing symbols when real elisp
77 (define (backquote? sym)
78 (and (symbol? sym) (or (eq? sym 'quasiquote)
81 (define (unquote? sym)
82 (and (symbol? sym) (or (eq? sym 'unquote)
85 (define (unquote-splicing? sym)
86 (and (symbol? sym) (or (eq? sym 'unquote-splicing)
90 ; Build a call to a primitive procedure nicely.
92 (define (call-primitive loc sym . args)
93 (make-application loc (make-primitive-ref loc sym) args))
96 ; Error reporting routine for syntax/compilation problems or build code for
97 ; a runtime-error output.
99 (define (report-error loc . args)
102 (define (runtime-error loc msg . args)
103 (make-application loc (make-primitive-ref loc 'error)
104 (cons (make-const loc msg) args)))
107 ; Generate code to ensure a fluid is there for further use of a given symbol.
108 ; In general during the compilation, fluids needed are only tracked with the
109 ; bindings data structure. Afterwards, however, for all those needed symbols
110 ; the fluids are really generated with this routine.
112 (define (generate-ensure-fluid loc sym module)
113 (make-application loc (make-module-ref loc runtime 'ensure-fluid! #t)
114 (list (make-const loc module)
115 (make-const loc sym))))
118 ; See if we should do a void-check for a given variable. That means, check
119 ; that this check is not disabled via the compiler options for this symbol.
120 ; Disabling of void check is only done for the value-slot module!
122 (define (want-void-check? sym module)
123 (let ((disabled (fluid-ref disable-void-check)))
124 (or (not (equal? module value-slot))
125 (and (not (eq? disabled 'all))
126 (not (memq sym disabled))))))
129 ; Handle access to a variable (reference/setting) correctly depending on
130 ; whether it is currently lexically or dynamically bound.
131 ; lexical access is done only for references to the value-slot module!
133 (define (access-variable loc sym module handle-lexical handle-dynamic)
134 (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
135 (if (and lexical (equal? module value-slot))
136 (handle-lexical lexical)
140 ; Generate code to reference a variable.
141 ; For references in the value-slot module, we may want to generate a lexical
142 ; reference instead if the variable has a lexical binding.
144 (define (reference-variable loc sym module)
145 (access-variable loc sym module
147 (make-lexical-ref loc lexical lexical))
149 (mark-fluid-needed! (fluid-ref bindings-data) sym module)
150 (call-primitive loc 'fluid-ref
151 (make-module-ref loc module sym #t)))))
154 ; Reference a variable and error if the value is void.
156 (define (reference-with-check loc sym module)
157 (if (want-void-check? sym module)
158 (let ((var (gensym)))
159 (make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
160 (make-conditional loc
161 (call-primitive loc 'eq?
162 (make-module-ref loc runtime 'void #t)
163 (make-lexical-ref loc 'value var))
164 (runtime-error loc "variable is void:" (make-const loc sym))
165 (make-lexical-ref loc 'value var))))
166 (reference-variable loc sym module)))
169 ; Generate code to set a variable.
170 ; Just as with reference-variable, in case of a reference to value-slot,
171 ; we want to generate a lexical set when the variable has a lexical binding.
173 (define (set-variable! loc sym module value)
174 (access-variable loc sym module
176 (make-lexical-set loc lexical lexical value))
178 (mark-fluid-needed! (fluid-ref bindings-data) sym module)
179 (call-primitive loc 'fluid-set!
180 (make-module-ref loc module sym #t)
184 ; Process the bindings part of a let or let* expression; that is, check for
185 ; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...).
187 (define (process-let-bindings loc bindings)
191 (if (or (not (list? b))
192 (not (= (length b) 2)))
193 (report-error loc "expected symbol or list of 2 elements in let")
194 (if (not (symbol? (car b)))
195 (report-error loc "expected symbol in let")
196 (cons (car b) (cadr b))))))
200 ; Split the let bindings into a list to be done lexically and one dynamically.
201 ; A symbol will be bound lexically if and only if:
202 ; We're processing a lexical-let (i.e. module is 'lexical), OR
203 ; we're processing a value-slot binding AND
204 ; the symbol is already lexically bound or it is always lexical.
206 (define (bind-lexically? sym module)
207 (or (eq? module 'lexical)
208 (and (equal? module value-slot)
209 (let ((always (fluid-ref always-lexical)))
210 (or (eq? always 'all)
212 (get-lexical-binding (fluid-ref bindings-data) sym))))))
214 (define (split-let-bindings bindings module)
215 (let iterate ((tail bindings)
219 (values (reverse lexical) (reverse dynamic))
220 (if (bind-lexically? (caar tail) module)
221 (iterate (cdr tail) (cons (car tail) lexical) dynamic)
222 (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
225 ; Compile let and let* expressions. The code here is used both for let/let*
226 ; and flet/flet*, just with a different bindings module.
228 ; A special module value 'lexical means that we're doing a lexical-let instead
229 ; and the bindings should not be safed to fluids at all but be done with the
230 ; lexical framework instead.
232 ; Let is done with a single call to with-fluids* binding them locally to new
233 ; values all "at once". If there is at least one variable to bind lexically
234 ; among the bindings, we first do a let for all of them to evaluate all
235 ; values before any bindings take place, and then call with-fluids* for the
236 ; variables to bind dynamically.
237 (define (generate-let loc module bindings body)
238 (let ((bind (process-let-bindings loc bindings)))
241 (split-let-bindings bind module))
242 (lambda (lexical dynamic)
243 (for-each (lambda (sym)
244 (mark-fluid-needed! (fluid-ref bindings-data) sym module))
246 (let ((fluids (make-application loc (make-primitive-ref loc 'list)
248 (make-module-ref loc module (car el) #t))
250 (make-values (lambda (for)
252 (compile-expr (cdr el)))
254 (make-body (lambda ()
255 (make-sequence loc (map compile-expr body)))))
257 (call-primitive loc 'with-fluids*
259 (make-application loc (make-primitive-ref loc 'list)
260 (make-values dynamic))
261 (make-lambda loc '() '() '() (make-body)))
262 (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
263 (dynamic-syms (map (lambda (el) (gensym)) dynamic))
264 (all-syms (append lexical-syms dynamic-syms))
265 (vals (append (make-values lexical) (make-values dynamic))))
266 (make-let loc all-syms all-syms vals
267 (with-lexical-bindings (fluid-ref bindings-data)
268 (map car lexical) lexical-syms
272 (call-primitive loc 'with-fluids*
274 (make-application loc (make-primitive-ref loc 'list)
275 (map (lambda (sym) (make-lexical-ref loc sym sym))
277 (make-lambda loc '() '() '() (make-body))))))))))))))
280 ; Let* is compiled to a cascaded set of "small lets" for each binding in turn
281 ; so that each one already sees the preceding bindings.
282 (define (generate-let* loc module bindings body)
283 (let ((bind (process-let-bindings loc bindings)))
285 (for-each (lambda (sym)
286 (if (not (bind-lexically? sym module))
287 (mark-fluid-needed! (fluid-ref bindings-data) sym module)))
289 (let iterate ((tail bind))
291 (make-sequence loc (map compile-expr body))
292 (let ((sym (caar tail))
293 (value (compile-expr (cdar tail))))
294 (if (bind-lexically? sym module)
295 (let ((target (gensym)))
296 (make-let loc `(,target) `(,target) `(,value)
297 (with-lexical-bindings (fluid-ref bindings-data)
300 (iterate (cdr tail))))))
301 (call-primitive loc 'with-fluid*
302 (make-module-ref loc module (caar tail) #t) value
303 (make-lambda loc '() '() '() (iterate (cdr tail)))))))))))
306 ; Split the argument list of a lambda expression into required, optional and
307 ; rest arguments and also check it is actually valid.
308 ; Additionally, we create a list of all "local variables" (that is, required,
309 ; optional and rest arguments together) and also this one split into those to
310 ; be bound lexically and dynamically.
311 ; Returned is as multiple values: required optional rest lexical dynamic
313 (define (bind-arg-lexical? arg)
314 (let ((always (fluid-ref always-lexical)))
315 (or (eq? always 'all)
318 (define (split-lambda-arguments loc args)
319 (let iterate ((tail args)
328 (let ((final-required (reverse required))
329 (final-optional (reverse optional))
330 (final-lexical (reverse lexical))
331 (final-dynamic (reverse dynamic)))
332 (values final-required final-optional #f
333 final-lexical final-dynamic)))
335 ((and (eq? mode 'required)
336 (eq? (car tail) '&optional))
337 (iterate (cdr tail) 'optional required optional lexical dynamic))
339 ((eq? (car tail) '&rest)
340 (if (or (null? (cdr tail))
341 (not (null? (cddr tail))))
342 (report-error loc "expected exactly one symbol after &rest")
343 (let* ((rest (cadr tail))
344 (rest-lexical (bind-arg-lexical? rest))
345 (final-required (reverse required))
346 (final-optional (reverse optional))
347 (final-lexical (reverse (if rest-lexical
350 (final-dynamic (reverse (if rest-lexical
352 (cons rest dynamic)))))
353 (values final-required final-optional rest
354 final-lexical final-dynamic))))
357 (if (not (symbol? (car tail)))
358 (report-error loc "expected symbol in argument list, got" (car tail))
359 (let* ((arg (car tail))
360 (bind-lexical (bind-arg-lexical? arg))
361 (new-lexical (if bind-lexical
364 (new-dynamic (if bind-lexical
366 (cons arg dynamic))))
368 ((required) (iterate (cdr tail) mode
369 (cons arg required) optional
370 new-lexical new-dynamic))
371 ((optional) (iterate (cdr tail) mode
372 required (cons arg optional)
373 new-lexical new-dynamic))
375 (error "invalid mode in split-lambda-arguments" mode)))))))))
378 ; Compile a lambda expression. Things get a little complicated because TreeIL
379 ; does not allow optional arguments but only one rest argument, and also the
380 ; rest argument should be nil instead of '() for no values given. Because of
381 ; this, we have to do a little preprocessing to get everything done before the
382 ; real body is called.
384 ; (lambda (a &optional b &rest c) body) should become:
385 ; (lambda (a_ . rest_)
386 ; (with-fluids* (list a b c) (list a_ nil nil)
388 ; (if (not (null? rest_))
390 ; (fluid-set! b (car rest_))
391 ; (set! rest_ (cdr rest_))
392 ; (if (not (null? rest_))
393 ; (fluid-set! c rest_))))
396 ; This is formulated very imperatively, but I think in this case that is quite
397 ; clear and better than creating a lot of nested let's.
399 ; Another thing we have to be aware of is that lambda arguments are usually
400 ; dynamically bound, even when a lexical binding is in tact for a symbol.
401 ; For symbols that are marked as 'always lexical' however, we bind them here
402 ; lexically, too -- and thus we get them out of the with-fluids* call and
403 ; register a lexical binding for them (the lexical target variable is already
404 ; there, namely the real lambda argument from TreeIL).
405 ; For optional arguments that are lexically bound we need to create the lexical
406 ; bindings though with an additional let, as those arguments are not part of the
407 ; ordinary argument list.
409 (define (compile-lambda loc args body)
410 (if (not (list? args))
411 (report-error loc "expected list for argument-list" args))
413 (report-error loc "function body might not be empty"))
416 (split-lambda-arguments loc args))
417 (lambda (required optional rest lexical dynamic)
418 (let* ((make-sym (lambda (sym) (gensym)))
419 (required-sym (map make-sym required))
420 (required-pairs (map cons required required-sym))
421 (have-real-rest (or rest (not (null? optional))))
422 (rest-sym (if have-real-rest (gensym) '()))
423 (rest-name (if rest rest rest-sym))
424 (rest-lexical (and rest (memq rest lexical)))
425 (rest-dynamic (and rest (not rest-lexical)))
426 (real-args (append required-sym rest-sym))
427 (arg-names (append required rest-name))
428 (lex-optionals (lset-intersection eq? optional lexical))
429 (dyn-optionals (lset-intersection eq? optional dynamic))
430 (optional-sym (map make-sym lex-optionals))
431 (optional-lex-pairs (map cons lex-optionals optional-sym))
432 (find-required-pairs (lambda (filter)
433 (lset-intersection (lambda (name-sym el)
436 required-pairs filter)))
437 (required-lex-pairs (find-required-pairs lexical))
438 (rest-pair (if rest-lexical `((,rest . ,rest-sym)) '()))
439 (all-lex-pairs (append required-lex-pairs optional-lex-pairs
441 (for-each (lambda (sym)
442 (mark-fluid-needed! (fluid-ref bindings-data)
445 (with-dynamic-bindings (fluid-ref bindings-data) dynamic
447 (with-lexical-bindings (fluid-ref bindings-data)
448 (map car all-lex-pairs)
449 (map cdr all-lex-pairs)
452 arg-names real-args '()
453 (let* ((fluids (map (lambda (sym)
454 (make-module-ref loc value-slot sym #t))
456 (init-req (map (lambda (name-sym)
457 (make-lexical-ref loc (car name-sym)
459 (find-required-pairs dynamic)))
460 (init-nils (map (lambda (sym) (nil-value loc))
462 `(,@dyn-optionals ,rest-sym)
464 (init (append init-req init-nils))
465 (func-body (make-sequence loc
466 `(,(process-optionals loc optional
468 ,(process-rest loc rest
470 ,@(map compile-expr body))))
471 (with-fluids-call (call-primitive loc 'with-fluids*
472 (make-application loc
473 (make-primitive-ref loc 'list)
475 (make-application loc
476 (make-primitive-ref loc 'list)
478 (make-lambda loc '() '() '()
480 (full-body (if (null? dynamic)
483 (if (null? optional-sym)
486 optional-sym optional-sym
487 (map (lambda (sym) (nil-value loc)) optional-sym)
488 full-body))))))))))))
490 ; Build the code to handle setting of optional arguments that are present
491 ; and updating the rest list.
492 (define (process-optionals loc optional rest-name rest-sym)
493 (let iterate ((tail optional))
496 (make-conditional loc
497 (call-primitive loc 'null? (make-lexical-ref loc rest-name rest-sym))
500 (list (set-variable! loc (car tail) value-slot
501 (call-primitive loc 'car
502 (make-lexical-ref loc rest-name rest-sym)))
503 (make-lexical-set loc rest-name rest-sym
504 (call-primitive loc 'cdr
505 (make-lexical-ref loc rest-name rest-sym)))
506 (iterate (cdr tail))))))))
508 ; This builds the code to set the rest variable to nil if it is empty.
509 (define (process-rest loc rest rest-name rest-sym)
510 (let ((rest-empty (call-primitive loc 'null?
511 (make-lexical-ref loc rest-name rest-sym))))
514 (make-conditional loc rest-empty
516 (set-variable! loc rest value-slot
517 (make-lexical-ref loc rest-name rest-sym))))
518 ((not (null? rest-sym))
519 (make-conditional loc rest-empty
521 (runtime-error loc "too many arguments and no rest argument")))
522 (else (make-void loc)))))
525 ; Handle the common part of defconst and defvar, that is, checking for a correct
526 ; doc string and arguments as well as maybe in the future handling the docstring
529 (define (handle-var-def loc sym doc)
531 ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
532 ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
533 ((and (not (null? doc)) (not (string? (car doc))))
534 (report-error loc "expected string as third argument of defvar, got"
536 ; TODO: Handle doc string if present.
540 ; Handle macro bindings.
542 (define (is-macro? sym)
543 (module-defined? (resolve-interface macro-slot) sym))
545 (define (define-macro! loc sym definition)
546 (let ((resolved (resolve-module macro-slot)))
548 (report-error loc "macro is already defined" sym)
550 (module-define! resolved sym definition)
551 (module-export! resolved (list sym))))))
553 (define (get-macro sym)
554 (module-ref (resolve-module macro-slot) sym))
557 ; See if a (backquoted) expression contains any unquotes.
559 (define (contains-unquotes? expr)
561 (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
563 (or (contains-unquotes? (car expr))
564 (contains-unquotes? (cdr expr))))
568 ; Process a backquoted expression by building up the needed cons/append calls.
569 ; For splicing, it is assumed that the expression spliced in evaluates to a
570 ; list. The emacs manual does not really state either it has to or what to do
571 ; if it does not, but Scheme explicitly forbids it and this seems reasonable
574 (define (unquote-cell? expr)
575 (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
576 (define (unquote-splicing-cell? expr)
577 (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
579 (define (process-backquote loc expr)
580 (if (contains-unquotes? expr)
582 (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
583 (compile-expr (cadr expr))
584 (let* ((head (car expr))
585 (processed-tail (process-backquote loc (cdr expr)))
586 (head-is-list-2 (and (list? head) (= (length head) 2)))
587 (head-unquote (and head-is-list-2 (unquote? (car head))))
588 (head-unquote-splicing (and head-is-list-2
589 (unquote-splicing? (car head)))))
590 (if head-unquote-splicing
591 (call-primitive loc 'append
592 (compile-expr (cadr head)) processed-tail)
593 (call-primitive loc 'cons
595 (compile-expr (cadr head))
596 (process-backquote loc head))
598 (report-error loc "non-pair expression contains unquotes" expr))
599 (make-const loc expr)))
602 ; Temporarily update a list of symbols that are handled specially (disabled
603 ; void check or always lexical) for compiling body.
604 ; We need to handle special cases for already all / set to all and the like.
606 (define (with-added-symbols loc fluid syms body)
608 (report-error loc "symbol-list construct has empty body"))
609 (if (not (or (eq? syms 'all)
610 (and (list? syms) (and-map symbol? syms))))
611 (report-error loc "invalid symbol list" syms))
612 (let ((old (fluid-ref fluid))
613 (make-body (lambda ()
614 (make-sequence loc (map compile-expr body)))))
617 (let ((new (if (eq? syms 'all)
620 (with-fluids ((fluid new))
624 ; Compile a symbol expression. This is a variable reference or maybe some
625 ; special value like nil.
627 (define (compile-symbol loc sym)
629 ((nil) (nil-value loc))
631 (else (reference-with-check loc sym value-slot))))
634 ; Compile a pair-expression (that is, any structure-like construct).
636 (define (compile-pair loc expr)
640 (make-sequence loc (map compile-expr forms)))
642 ((if ,condition ,ifclause)
643 (make-conditional loc (compile-expr condition)
644 (compile-expr ifclause)
646 ((if ,condition ,ifclause ,elseclause)
647 (make-conditional loc (compile-expr condition)
648 (compile-expr ifclause)
649 (compile-expr elseclause)))
650 ((if ,condition ,ifclause . ,elses)
651 (make-conditional loc (compile-expr condition)
652 (compile-expr ifclause)
653 (make-sequence loc (map compile-expr elses))))
655 ; defconst and defvar are kept here in the compiler (rather than doing them
656 ; as macros) for if we may want to handle the docstring somehow.
658 ((defconst ,sym ,value . ,doc)
659 (if (handle-var-def loc sym doc)
661 (list (set-variable! loc sym value-slot (compile-expr value))
662 (make-const loc sym)))))
664 ((defvar ,sym) (make-const loc sym))
665 ((defvar ,sym ,value . ,doc)
666 (if (handle-var-def loc sym doc)
668 (list (make-conditional loc
669 (call-primitive loc 'eq?
670 (make-module-ref loc runtime 'void #t)
671 (reference-variable loc sym value-slot))
672 (set-variable! loc sym value-slot
673 (compile-expr value))
675 (make-const loc sym)))))
677 ; Build a set form for possibly multiple values. The code is not formulated
678 ; tail recursive because it is clearer this way and large lists of symbol
679 ; expression pairs are very unlikely.
680 ((setq . ,args) (guard (not (null? args)))
682 (let iterate ((tail args))
683 (let ((sym (car tail))
684 (tailtail (cdr tail)))
685 (if (not (symbol? sym))
686 (report-error loc "expected symbol in setq")
688 (report-error loc "missing value for symbol in setq" sym)
689 (let* ((val (compile-expr (car tailtail)))
690 (op (set-variable! loc sym value-slot val)))
691 (if (null? (cdr tailtail))
692 (let* ((temp (gensym))
693 (ref (make-lexical-ref loc temp temp)))
694 (list (make-let loc `(,temp) `(,temp) `(,val)
696 (list (set-variable! loc sym value-slot ref)
698 (cons (set-variable! loc sym value-slot val)
699 (iterate (cdr tailtail)))))))))))
701 ; All lets (let, flet, lexical-let and let* forms) are done using the
702 ; generate-let/generate-let* methods.
704 ((let ,bindings . ,body) (guard (and (list? bindings)
705 (not (null? bindings))
707 (generate-let loc value-slot bindings body))
708 ((lexical-let ,bindings . ,body) (guard (and (list? bindings)
709 (not (null? bindings))
711 (generate-let loc 'lexical bindings body))
712 ((flet ,bindings . ,body) (guard (and (list? bindings)
713 (not (null? bindings))
715 (generate-let loc function-slot bindings body))
717 ((let* ,bindings . ,body) (guard (and (list? bindings)
718 (not (null? bindings))
720 (generate-let* loc value-slot bindings body))
721 ((lexical-let* ,bindings . ,body) (guard (and (list? bindings)
722 (not (null? bindings))
724 (generate-let* loc 'lexical bindings body))
725 ((flet* ,bindings . ,body) (guard (and (list? bindings)
726 (not (null? bindings))
728 (generate-let* loc function-slot bindings body))
730 ; Temporarily disable void checks or set symbols as always lexical only
731 ; for the lexical scope of a construct.
733 ((without-void-checks ,syms . ,body)
734 (with-added-symbols loc disable-void-check syms body))
736 ((with-always-lexical ,syms . ,body)
737 (with-added-symbols loc always-lexical syms body))
739 ; guile-ref allows building TreeIL's module references from within
740 ; elisp as a way to access data within
741 ; the Guile universe. The module and symbol referenced are static values,
742 ; just like (@ module symbol) does!
743 ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym)))
744 (make-module-ref loc module sym #t))
746 ; guile-primitive allows to create primitive references, which are still
748 ((guile-primitive ,sym) (guard (symbol? sym))
749 (make-primitive-ref loc sym))
751 ; A while construct is transformed into a tail-recursive loop like this:
752 ; (letrec ((iterate (lambda ()
758 ((while ,condition . ,body)
759 (let* ((itersym (gensym))
760 (compiled-body (map compile-expr body))
761 (iter-call (make-application loc
762 (make-lexical-ref loc 'iterate itersym)
764 (full-body (make-sequence loc
765 `(,@compiled-body ,iter-call)))
766 (lambda-body (make-conditional loc
767 (compile-expr condition)
770 (iter-thunk (make-lambda loc '() '() '() lambda-body)))
771 (make-letrec loc '(iterate) (list itersym) (list iter-thunk)
774 ; catch and throw can mainly be implemented directly using Guile's
775 ; primitives for exceptions, the only difficulty is that the keys used
776 ; within Guile must be symbols, while elisp allows any value and checks
777 ; for matches using eq (eq?). We handle this by using always #t as key
778 ; for the Guile primitives and check for matches inside the handler; if
779 ; the elisp keys are not eq?, we rethrow the exception.
781 ; TODO: Implement catch with a macro once we can build the lambda with
784 ; throw is implemented as built-in function.
786 ((catch ,tag . ,body) (guard (not (null? body)))
787 (let* ((tag-value (gensym))
788 (tag-ref (make-lexical-ref loc tag-value tag-value)))
789 (make-let loc `(,tag-value) `(,tag-value) `(,(compile-expr tag))
790 (call-primitive loc 'catch
792 (make-lambda loc '() '() '()
793 (make-sequence loc (map compile-expr body)))
794 (let* ((dummy-key (gensym))
795 (dummy-ref (make-lexical-ref loc dummy-key dummy-key))
797 (key-ref (make-lexical-ref loc elisp-key elisp-key))
799 (value-ref (make-lexical-ref loc value value))
800 (arglist `(,dummy-key ,elisp-key ,value)))
801 (make-lambda loc arglist arglist '()
802 (make-conditional loc
803 (call-primitive loc 'eq? key-ref tag-ref)
805 (call-primitive loc 'throw
806 dummy-ref key-ref value-ref))))))))
808 ; unwind-protect is just some weaker construct as dynamic-wind, so
809 ; straight-forward to implement.
810 ; TODO: This might be implemented as a macro, once lambda's without
811 ; arguments do not call with-fluids* anymore.
812 ((unwind-protect ,body . ,clean-ups) (guard (not (null? clean-ups)))
813 (call-primitive loc 'dynamic-wind
814 (make-lambda loc '() '() '() (make-void loc))
815 (make-lambda loc '() '() '()
817 (make-lambda loc '() '() '()
819 (map compile-expr clean-ups)))))
821 ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression
822 ; that should be compiled.
823 ((lambda ,args . ,body)
824 (compile-lambda loc args body))
825 ((function (lambda ,args . ,body))
826 (compile-lambda loc args body))
828 ; Build a lambda and also assign it to the function cell of some symbol.
829 ; This is no macro as we might want to honour the docstring at some time;
830 ; just as with defvar/defconst.
831 ((defun ,name ,args . ,body)
832 (if (not (symbol? name))
833 (report-error loc "expected symbol as function name" name)
835 (list (set-variable! loc name function-slot
836 (compile-lambda loc args body))
837 (make-const loc name)))))
839 ; Define a macro (this is done directly at compile-time!).
840 ; FIXME: Recursive macros don't work!
841 ((defmacro ,name ,args . ,body)
842 (if (not (symbol? name))
843 (report-error loc "expected symbol as macro name" name)
844 (let* ((tree-il (with-fluids ((bindings-data (make-bindings)))
845 (compile-lambda loc args body)))
846 (object (compile tree-il #:from 'tree-il #:to 'value)))
847 (define-macro! loc name object)
848 (make-const loc name))))
850 ; XXX: Maybe we could implement backquotes in macros, too.
851 ((,backq ,val) (guard (backquote? backq))
852 (process-backquote loc val))
854 ; XXX: Why do we need 'quote here instead of quote?
856 (make-const loc val))
858 ; Macro calls are simply expanded and recursively compiled.
859 ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro)))
860 (let ((expander (get-macro macro)))
861 (compile-expr (apply expander args))))
863 ; Function calls using (function args) standard notation; here, we have to
864 ; take the function value of a symbol if it is one. It seems that functions
865 ; in form of uncompiled lists are not supported in this syntax, so we don't
866 ; have to care for them.
868 (make-application loc
870 (reference-with-check loc func function-slot)
872 (map compile-expr args)))
875 (report-error loc "unrecognized elisp" expr))))
878 ; Compile a single expression to TreeIL.
880 (define (compile-expr expr)
881 (let ((loc (location expr)))
884 (compile-symbol loc expr))
886 (compile-pair loc expr))
887 (else (make-const loc expr)))))
890 ; Process the compiler options.
891 ; FIXME: Why is '(()) passed as options by the REPL?
893 (define (valid-symbol-list-arg? value)
895 (and (list? value) (and-map symbol? value))))
897 (define (process-options! opt)
898 (if (and (not (null? opt))
899 (not (equal? opt '(()))))
900 (if (null? (cdr opt))
901 (report-error #f "Invalid compiler options" opt)
902 (let ((key (car opt))
905 ((#:disable-void-check)
906 (if (valid-symbol-list-arg? value)
907 (fluid-set! disable-void-check value)
908 (report-error #f "Invalid value for #:disable-void-check" value)))
910 (if (valid-symbol-list-arg? value)
911 (fluid-set! always-lexical value)
912 (report-error #f "Invalid value for #:always-lexical" value)))
913 (else (report-error #f "Invalid compiler option" key)))))))
916 ; Entry point for compilation to TreeIL.
917 ; This creates the bindings data structure, and after compiling the main
918 ; expression we need to make sure all fluids for symbols used during the
919 ; compilation are created using the generate-ensure-fluid function.
921 (define (compile-tree-il expr env opts)
923 (with-fluids ((bindings-data (make-bindings))
924 (disable-void-check '())
925 (always-lexical '()))
926 (process-options! opts)
927 (let ((loc (location expr))
928 (compiled (compile-expr expr)))
930 `(,@(map-fluids-needed (fluid-ref bindings-data)
932 (generate-ensure-fluid loc sym mod)))