3 ;; Copyright (C) 2009, 2010 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 3, 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 (define (backquote? sym)
75 (and (symbol? sym) (eq? sym '\`)))
77 (define (unquote? sym)
78 (and (symbol? sym) (eq? sym '\,)))
80 (define (unquote-splicing? sym)
81 (and (symbol? sym) (eq? sym '\,@)))
84 ; Build a call to a primitive procedure nicely.
86 (define (call-primitive loc sym . args)
87 (make-application loc (make-primitive-ref loc sym) args))
90 ; Error reporting routine for syntax/compilation problems or build code for
91 ; a runtime-error output.
93 (define (report-error loc . args)
96 (define (runtime-error loc msg . args)
97 (make-application loc (make-primitive-ref loc 'error)
98 (cons (make-const loc msg) args)))
101 ; Generate code to ensure a global symbol is there for further use of a given
102 ; symbol. In general during the compilation, those needed are only tracked with
103 ; the bindings data structure. Afterwards, however, for all those needed
104 ; symbols the globals are really generated with this routine.
106 (define (generate-ensure-global loc sym module)
107 (make-application loc (make-module-ref loc runtime 'ensure-fluid! #t)
108 (list (make-const loc module)
109 (make-const loc sym))))
112 ; See if we should do a void-check for a given variable. That means, check
113 ; that this check is not disabled via the compiler options for this symbol.
114 ; Disabling of void check is only done for the value-slot module!
116 (define (want-void-check? sym module)
117 (let ((disabled (fluid-ref disable-void-check)))
118 (or (not (equal? module value-slot))
119 (and (not (eq? disabled 'all))
120 (not (memq sym disabled))))))
123 ; Build a construct that establishes dynamic bindings for certain variables.
124 ; We may want to choose between binding with fluids and with-fluids* and
125 ; using just ordinary module symbols and setting/reverting their values with
128 (define (let-dynamic loc syms module vals body)
129 (call-primitive loc 'with-fluids*
130 (make-application loc (make-primitive-ref loc 'list)
132 (make-module-ref loc module sym #t))
134 (make-application loc (make-primitive-ref loc 'list) vals)
136 (make-lambda-case #f '() #f #f #f '() '() body #f))))
139 ; Handle access to a variable (reference/setting) correctly depending on
140 ; whether it is currently lexically or dynamically bound.
141 ; lexical access is done only for references to the value-slot module!
143 (define (access-variable loc sym module handle-lexical handle-dynamic)
144 (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
145 (if (and lexical (equal? module value-slot))
146 (handle-lexical lexical)
150 ; Generate code to reference a variable.
151 ; For references in the value-slot module, we may want to generate a lexical
152 ; reference instead if the variable has a lexical binding.
154 (define (reference-variable loc sym module)
155 (access-variable loc sym module
157 (make-lexical-ref loc lexical lexical))
159 (mark-global-needed! (fluid-ref bindings-data) sym module)
160 (call-primitive loc 'fluid-ref
161 (make-module-ref loc module sym #t)))))
164 ; Reference a variable and error if the value is void.
166 (define (reference-with-check loc sym module)
167 (if (want-void-check? sym module)
168 (let ((var (gensym)))
169 (make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
170 (make-conditional loc
171 (call-primitive loc 'eq?
172 (make-module-ref loc runtime 'void #t)
173 (make-lexical-ref loc 'value var))
174 (runtime-error loc "variable is void:" (make-const loc sym))
175 (make-lexical-ref loc 'value var))))
176 (reference-variable loc sym module)))
179 ; Generate code to set a variable.
180 ; Just as with reference-variable, in case of a reference to value-slot,
181 ; we want to generate a lexical set when the variable has a lexical binding.
183 (define (set-variable! loc sym module value)
184 (access-variable loc sym module
186 (make-lexical-set loc lexical lexical value))
188 (mark-global-needed! (fluid-ref bindings-data) sym module)
189 (call-primitive loc 'fluid-set!
190 (make-module-ref loc module sym #t)
194 ; Process the bindings part of a let or let* expression; that is, check for
195 ; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...).
197 (define (process-let-bindings loc bindings)
201 (if (or (not (list? b))
202 (not (= (length b) 2)))
203 (report-error loc "expected symbol or list of 2 elements in let")
204 (if (not (symbol? (car b)))
205 (report-error loc "expected symbol in let")
206 (cons (car b) (cadr b))))))
210 ; Split the let bindings into a list to be done lexically and one dynamically.
211 ; A symbol will be bound lexically if and only if:
212 ; We're processing a lexical-let (i.e. module is 'lexical), OR
213 ; we're processing a value-slot binding AND
214 ; the symbol is already lexically bound or it is always lexical.
216 (define (bind-lexically? sym module)
217 (or (eq? module 'lexical)
218 (and (equal? module value-slot)
219 (let ((always (fluid-ref always-lexical)))
220 (or (eq? always 'all)
222 (get-lexical-binding (fluid-ref bindings-data) sym))))))
224 (define (split-let-bindings bindings module)
225 (let iterate ((tail bindings)
229 (values (reverse lexical) (reverse dynamic))
230 (if (bind-lexically? (caar tail) module)
231 (iterate (cdr tail) (cons (car tail) lexical) dynamic)
232 (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
235 ; Compile let and let* expressions. The code here is used both for let/let*
236 ; and flet/flet*, just with a different bindings module.
238 ; A special module value 'lexical means that we're doing a lexical-let instead
239 ; and the bindings should not be saved to globals at all but be done with the
240 ; lexical framework instead.
242 ; Let is done with a single call to let-dynamic binding them locally to new
243 ; values all "at once". If there is at least one variable to bind lexically
244 ; among the bindings, we first do a let for all of them to evaluate all
245 ; values before any bindings take place, and then call let-dynamic for the
246 ; variables to bind dynamically.
247 (define (generate-let loc module bindings body)
248 (let ((bind (process-let-bindings loc bindings)))
251 (split-let-bindings bind module))
252 (lambda (lexical dynamic)
253 (for-each (lambda (sym)
254 (mark-global-needed! (fluid-ref bindings-data) sym module))
256 (let ((make-values (lambda (for)
258 (compile-expr (cdr el)))
260 (make-body (lambda ()
261 (make-sequence loc (map compile-expr body)))))
263 (let-dynamic loc (map car dynamic) module
264 (make-values dynamic) (make-body))
265 (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
266 (dynamic-syms (map (lambda (el) (gensym)) dynamic))
267 (all-syms (append lexical-syms dynamic-syms))
268 (vals (append (make-values lexical) (make-values dynamic))))
269 (make-let loc all-syms all-syms vals
270 (with-lexical-bindings (fluid-ref bindings-data)
271 (map car lexical) lexical-syms
275 (let-dynamic loc (map car dynamic) module
277 (make-lexical-ref loc sym sym))
279 (make-body)))))))))))))
282 ; Let* is compiled to a cascaded set of "small lets" for each binding in turn
283 ; so that each one already sees the preceding bindings.
284 (define (generate-let* loc module bindings body)
285 (let ((bind (process-let-bindings loc bindings)))
287 (for-each (lambda (sym)
288 (if (not (bind-lexically? sym module))
289 (mark-global-needed! (fluid-ref bindings-data) sym module)))
291 (let iterate ((tail bind))
293 (make-sequence loc (map compile-expr body))
294 (let ((sym (caar tail))
295 (value (compile-expr (cdar tail))))
296 (if (bind-lexically? sym module)
297 (let ((target (gensym)))
298 (make-let loc `(,target) `(,target) `(,value)
299 (with-lexical-bindings (fluid-ref bindings-data)
302 (iterate (cdr tail))))))
304 `(,(caar tail)) module `(,value)
305 (iterate (cdr tail))))))))))
308 ; Split the argument list of a lambda expression into required, optional and
309 ; rest arguments and also check it is actually valid.
310 ; Additionally, we create a list of all "local variables" (that is, required,
311 ; optional and rest arguments together) and also this one split into those to
312 ; be bound lexically and dynamically.
313 ; Returned is as multiple values: required optional rest lexical dynamic
315 (define (bind-arg-lexical? arg)
316 (let ((always (fluid-ref always-lexical)))
317 (or (eq? always 'all)
320 (define (split-lambda-arguments loc args)
321 (let iterate ((tail args)
330 (let ((final-required (reverse required))
331 (final-optional (reverse optional))
332 (final-lexical (reverse lexical))
333 (final-dynamic (reverse dynamic)))
334 (values final-required final-optional #f
335 final-lexical final-dynamic)))
337 ((and (eq? mode 'required)
338 (eq? (car tail) '&optional))
339 (iterate (cdr tail) 'optional required optional lexical dynamic))
341 ((eq? (car tail) '&rest)
342 (if (or (null? (cdr tail))
343 (not (null? (cddr tail))))
344 (report-error loc "expected exactly one symbol after &rest")
345 (let* ((rest (cadr tail))
346 (rest-lexical (bind-arg-lexical? rest))
347 (final-required (reverse required))
348 (final-optional (reverse optional))
349 (final-lexical (reverse (if rest-lexical
352 (final-dynamic (reverse (if rest-lexical
354 (cons rest dynamic)))))
355 (values final-required final-optional rest
356 final-lexical final-dynamic))))
359 (if (not (symbol? (car tail)))
360 (report-error loc "expected symbol in argument list, got" (car tail))
361 (let* ((arg (car tail))
362 (bind-lexical (bind-arg-lexical? arg))
363 (new-lexical (if bind-lexical
366 (new-dynamic (if bind-lexical
368 (cons arg dynamic))))
370 ((required) (iterate (cdr tail) mode
371 (cons arg required) optional
372 new-lexical new-dynamic))
373 ((optional) (iterate (cdr tail) mode
374 required (cons arg optional)
375 new-lexical new-dynamic))
377 (error "invalid mode in split-lambda-arguments" mode)))))))))
380 ; Compile a lambda expression. Things get a little complicated because TreeIL
381 ; does not allow optional arguments but only one rest argument, and also the
382 ; rest argument should be nil instead of '() for no values given. Because of
383 ; this, we have to do a little preprocessing to get everything done before the
384 ; real body is called.
386 ; (lambda (a &optional b &rest c) body) should become:
387 ; (lambda (a_ . rest_)
388 ; (with-fluids* (list a b c) (list a_ nil nil)
390 ; (if (not (null? rest_))
392 ; (fluid-set! b (car rest_))
393 ; (set! rest_ (cdr rest_))
394 ; (if (not (null? rest_))
395 ; (fluid-set! c rest_))))
398 ; This is formulated very imperatively, but I think in this case that is quite
399 ; clear and better than creating a lot of nested let's.
401 ; Another thing we have to be aware of is that lambda arguments are usually
402 ; dynamically bound, even when a lexical binding is in tact for a symbol.
403 ; For symbols that are marked as 'always lexical' however, we bind them here
404 ; lexically, too -- and thus we get them out of the let-dynamic call and
405 ; register a lexical binding for them (the lexical target variable is already
406 ; there, namely the real lambda argument from TreeIL).
407 ; For optional arguments that are lexically bound we need to create the lexical
408 ; bindings though with an additional let, as those arguments are not part of the
409 ; ordinary argument list.
411 (define (compile-lambda loc args body)
412 (if (not (list? args))
413 (report-error loc "expected list for argument-list" args))
415 (report-error loc "function body might not be empty"))
418 (split-lambda-arguments loc args))
419 (lambda (required optional rest lexical dynamic)
420 (let* ((make-sym (lambda (sym) (gensym)))
421 (required-sym (map make-sym required))
422 (required-pairs (map cons required required-sym))
423 (have-real-rest (or rest (not (null? optional))))
424 (rest-sym (if have-real-rest (gensym) '()))
425 (rest-name (if rest rest rest-sym))
426 (rest-lexical (and rest (memq rest lexical)))
427 (rest-dynamic (and rest (not rest-lexical)))
428 (real-args (append required-sym rest-sym))
429 (arg-names (append required rest-name))
430 (lex-optionals (lset-intersection eq? optional lexical))
431 (dyn-optionals (lset-intersection eq? optional dynamic))
432 (optional-sym (map make-sym lex-optionals))
433 (optional-lex-pairs (map cons lex-optionals optional-sym))
434 (find-required-pairs (lambda (filter)
435 (lset-intersection (lambda (name-sym el)
438 required-pairs filter)))
439 (required-lex-pairs (find-required-pairs lexical))
440 (rest-pair (if rest-lexical `((,rest . ,rest-sym)) '()))
441 (all-lex-pairs (append required-lex-pairs optional-lex-pairs
443 (for-each (lambda (sym)
444 (mark-global-needed! (fluid-ref bindings-data)
447 (with-dynamic-bindings (fluid-ref bindings-data) dynamic
449 (with-lexical-bindings (fluid-ref bindings-data)
450 (map car all-lex-pairs)
451 (map cdr all-lex-pairs)
456 (if have-real-rest rest-name #f)
459 (append required-sym (list rest-sym))
461 (let* ((init-req (map (lambda (name-sym)
462 (make-lexical-ref loc (car name-sym)
464 (find-required-pairs dynamic)))
465 (init-nils (map (lambda (sym) (nil-value loc))
467 `(,@dyn-optionals ,rest-sym)
469 (init (append init-req init-nils))
470 (func-body (make-sequence loc
471 `(,(process-optionals loc optional
473 ,(process-rest loc rest
475 ,@(map compile-expr body))))
476 (dynlet (let-dynamic loc dynamic value-slot
478 (full-body (if (null? dynamic) func-body dynlet)))
479 (if (null? optional-sym)
482 optional-sym optional-sym
483 (map (lambda (sym) (nil-value loc)) optional-sym)
487 ; Build the code to handle setting of optional arguments that are present
488 ; and updating the rest list.
489 (define (process-optionals loc optional rest-name rest-sym)
490 (let iterate ((tail optional))
493 (make-conditional loc
494 (call-primitive loc 'null? (make-lexical-ref loc rest-name rest-sym))
497 (list (set-variable! loc (car tail) value-slot
498 (call-primitive loc 'car
499 (make-lexical-ref loc rest-name rest-sym)))
500 (make-lexical-set loc rest-name rest-sym
501 (call-primitive loc 'cdr
502 (make-lexical-ref loc rest-name rest-sym)))
503 (iterate (cdr tail))))))))
505 ; This builds the code to set the rest variable to nil if it is empty.
506 (define (process-rest loc rest rest-name rest-sym)
507 (let ((rest-empty (call-primitive loc 'null?
508 (make-lexical-ref loc rest-name rest-sym))))
511 (make-conditional loc rest-empty
513 (set-variable! loc rest value-slot
514 (make-lexical-ref loc rest-name rest-sym))))
515 ((not (null? rest-sym))
516 (make-conditional loc rest-empty
518 (runtime-error loc "too many arguments and no rest argument")))
519 (else (make-void loc)))))
522 ; Handle the common part of defconst and defvar, that is, checking for a correct
523 ; doc string and arguments as well as maybe in the future handling the docstring
526 (define (handle-var-def loc sym doc)
528 ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
529 ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
530 ((and (not (null? doc)) (not (string? (car doc))))
531 (report-error loc "expected string as third argument of defvar, got"
533 ; TODO: Handle doc string if present.
537 ; Handle macro bindings.
539 (define (is-macro? sym)
540 (module-defined? (resolve-interface macro-slot) sym))
542 (define (define-macro! loc sym definition)
543 (let ((resolved (resolve-module macro-slot)))
545 (report-error loc "macro is already defined" sym)
547 (module-define! resolved sym definition)
548 (module-export! resolved (list sym))))))
550 (define (get-macro sym)
551 (module-ref (resolve-module macro-slot) sym))
554 ; See if a (backquoted) expression contains any unquotes.
556 (define (contains-unquotes? expr)
558 (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
560 (or (contains-unquotes? (car expr))
561 (contains-unquotes? (cdr expr))))
565 ; Process a backquoted expression by building up the needed cons/append calls.
566 ; For splicing, it is assumed that the expression spliced in evaluates to a
567 ; list. The emacs manual does not really state either it has to or what to do
568 ; if it does not, but Scheme explicitly forbids it and this seems reasonable
571 (define (unquote-cell? expr)
572 (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
573 (define (unquote-splicing-cell? expr)
574 (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
576 (define (process-backquote loc expr)
577 (if (contains-unquotes? expr)
579 (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
580 (compile-expr (cadr expr))
581 (let* ((head (car expr))
582 (processed-tail (process-backquote loc (cdr expr)))
583 (head-is-list-2 (and (list? head) (= (length head) 2)))
584 (head-unquote (and head-is-list-2 (unquote? (car head))))
585 (head-unquote-splicing (and head-is-list-2
586 (unquote-splicing? (car head)))))
587 (if head-unquote-splicing
588 (call-primitive loc 'append
589 (compile-expr (cadr head)) processed-tail)
590 (call-primitive loc 'cons
592 (compile-expr (cadr head))
593 (process-backquote loc head))
595 (report-error loc "non-pair expression contains unquotes" expr))
596 (make-const loc expr)))
599 ; Temporarily update a list of symbols that are handled specially (disabled
600 ; void check or always lexical) for compiling body.
601 ; We need to handle special cases for already all / set to all and the like.
603 (define (with-added-symbols loc fluid syms body)
605 (report-error loc "symbol-list construct has empty body"))
606 (if (not (or (eq? syms 'all)
607 (and (list? syms) (and-map symbol? syms))))
608 (report-error loc "invalid symbol list" syms))
609 (let ((old (fluid-ref fluid))
610 (make-body (lambda ()
611 (make-sequence loc (map compile-expr body)))))
614 (let ((new (if (eq? syms 'all)
617 (with-fluids ((fluid new))
621 ; Compile a symbol expression. This is a variable reference or maybe some
622 ; special value like nil.
624 (define (compile-symbol loc sym)
626 ((nil) (nil-value loc))
628 (else (reference-with-check loc sym value-slot))))
631 ; Compile a pair-expression (that is, any structure-like construct).
633 (define (compile-pair loc expr)
637 (make-sequence loc (map compile-expr forms)))
639 ((if ,condition ,ifclause)
640 (make-conditional loc (compile-expr condition)
641 (compile-expr ifclause)
643 ((if ,condition ,ifclause ,elseclause)
644 (make-conditional loc (compile-expr condition)
645 (compile-expr ifclause)
646 (compile-expr elseclause)))
647 ((if ,condition ,ifclause . ,elses)
648 (make-conditional loc (compile-expr condition)
649 (compile-expr ifclause)
650 (make-sequence loc (map compile-expr elses))))
652 ; defconst and defvar are kept here in the compiler (rather than doing them
653 ; as macros) for if we may want to handle the docstring somehow.
655 ((defconst ,sym ,value . ,doc)
656 (if (handle-var-def loc sym doc)
658 (list (set-variable! loc sym value-slot (compile-expr value))
659 (make-const loc sym)))))
661 ((defvar ,sym) (make-const loc sym))
662 ((defvar ,sym ,value . ,doc)
663 (if (handle-var-def loc sym doc)
665 (list (make-conditional loc
666 (call-primitive loc 'eq?
667 (make-module-ref loc runtime 'void #t)
668 (reference-variable loc sym value-slot))
669 (set-variable! loc sym value-slot
670 (compile-expr value))
672 (make-const loc sym)))))
674 ; Build a set form for possibly multiple values. The code is not formulated
675 ; tail recursive because it is clearer this way and large lists of symbol
676 ; expression pairs are very unlikely.
677 ((setq . ,args) (guard (not (null? args)))
679 (let iterate ((tail args))
680 (let ((sym (car tail))
681 (tailtail (cdr tail)))
682 (if (not (symbol? sym))
683 (report-error loc "expected symbol in setq")
685 (report-error loc "missing value for symbol in setq" sym)
686 (let* ((val (compile-expr (car tailtail)))
687 (op (set-variable! loc sym value-slot val)))
688 (if (null? (cdr tailtail))
689 (let* ((temp (gensym))
690 (ref (make-lexical-ref loc temp temp)))
691 (list (make-let loc `(,temp) `(,temp) `(,val)
693 (list (set-variable! loc sym value-slot ref)
695 (cons (set-variable! loc sym value-slot val)
696 (iterate (cdr tailtail)))))))))))
698 ; All lets (let, flet, lexical-let and let* forms) are done using the
699 ; generate-let/generate-let* methods.
701 ((let ,bindings . ,body) (guard (and (list? bindings)
702 (not (null? bindings))
704 (generate-let loc value-slot bindings body))
705 ((lexical-let ,bindings . ,body) (guard (and (list? bindings)
706 (not (null? bindings))
708 (generate-let loc 'lexical bindings body))
709 ((flet ,bindings . ,body) (guard (and (list? bindings)
710 (not (null? bindings))
712 (generate-let loc function-slot bindings body))
714 ((let* ,bindings . ,body) (guard (and (list? bindings)
715 (not (null? bindings))
717 (generate-let* loc value-slot bindings body))
718 ((lexical-let* ,bindings . ,body) (guard (and (list? bindings)
719 (not (null? bindings))
721 (generate-let* loc 'lexical bindings body))
722 ((flet* ,bindings . ,body) (guard (and (list? bindings)
723 (not (null? bindings))
725 (generate-let* loc function-slot bindings body))
727 ; Temporarily disable void checks or set symbols as always lexical only
728 ; for the lexical scope of a construct.
730 ((without-void-checks ,syms . ,body)
731 (with-added-symbols loc disable-void-check syms body))
733 ((with-always-lexical ,syms . ,body)
734 (with-added-symbols loc always-lexical syms body))
736 ; guile-ref allows building TreeIL's module references from within
737 ; elisp as a way to access data within
738 ; the Guile universe. The module and symbol referenced are static values,
739 ; just like (@ module symbol) does!
740 ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym)))
741 (make-module-ref loc module sym #t))
743 ; guile-primitive allows to create primitive references, which are still
745 ((guile-primitive ,sym) (guard (symbol? sym))
746 (make-primitive-ref loc sym))
748 ; A while construct is transformed into a tail-recursive loop like this:
749 ; (letrec ((iterate (lambda ()
756 ; As letrec is not directly accessible from elisp, while is implemented here
757 ; instead of with a macro.
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 '()
771 (make-lambda-case #f '() #f #f #f '() '()
773 (make-letrec loc #f '(iterate) (list itersym) (list iter-thunk)
776 ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression
777 ; that should be compiled.
778 ((lambda ,args . ,body)
779 (compile-lambda loc args body))
780 ((function (lambda ,args . ,body))
781 (compile-lambda loc args body))
783 ; Build a lambda and also assign it to the function cell of some symbol.
784 ; This is no macro as we might want to honour the docstring at some time;
785 ; just as with defvar/defconst.
786 ((defun ,name ,args . ,body)
787 (if (not (symbol? name))
788 (report-error loc "expected symbol as function name" name)
790 (list (set-variable! loc name function-slot
791 (compile-lambda loc args body))
792 (make-const loc name)))))
794 ; Define a macro (this is done directly at compile-time!).
795 ; FIXME: Recursive macros don't work!
796 ((defmacro ,name ,args . ,body)
797 (if (not (symbol? name))
798 (report-error loc "expected symbol as macro name" name)
799 (let* ((tree-il (with-fluids ((bindings-data (make-bindings)))
800 (compile-lambda loc args body)))
801 (object (compile tree-il #:from 'tree-il #:to 'value)))
802 (define-macro! loc name object)
803 (make-const loc name))))
805 ; XXX: Maybe we could implement backquotes in macros, too.
806 ((,backq ,val) (guard (backquote? backq))
807 (process-backquote loc val))
809 ; XXX: Why do we need 'quote here instead of quote?
811 (make-const loc val))
813 ; Macro calls are simply expanded and recursively compiled.
814 ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro)))
815 (let ((expander (get-macro macro)))
816 (compile-expr (apply expander args))))
818 ; Function calls using (function args) standard notation; here, we have to
819 ; take the function value of a symbol if it is one. It seems that functions
820 ; in form of uncompiled lists are not supported in this syntax, so we don't
821 ; have to care for them.
823 (make-application loc
825 (reference-with-check loc func function-slot)
827 (map compile-expr args)))
830 (report-error loc "unrecognized elisp" expr))))
833 ; Compile a single expression to TreeIL.
835 (define (compile-expr expr)
836 (let ((loc (location expr)))
839 (compile-symbol loc expr))
841 (compile-pair loc expr))
842 (else (make-const loc expr)))))
845 ; Process the compiler options.
846 ; FIXME: Why is '(()) passed as options by the REPL?
848 (define (valid-symbol-list-arg? value)
850 (and (list? value) (and-map symbol? value))))
852 (define (process-options! opt)
853 (if (and (not (null? opt))
854 (not (equal? opt '(()))))
855 (if (null? (cdr opt))
856 (report-error #f "Invalid compiler options" opt)
857 (let ((key (car opt))
860 ((#:disable-void-check)
861 (if (valid-symbol-list-arg? value)
862 (fluid-set! disable-void-check value)
863 (report-error #f "Invalid value for #:disable-void-check" value)))
865 (if (valid-symbol-list-arg? value)
866 (fluid-set! always-lexical value)
867 (report-error #f "Invalid value for #:always-lexical" value)))
868 (else (report-error #f "Invalid compiler option" key)))))))
871 ; Entry point for compilation to TreeIL.
872 ; This creates the bindings data structure, and after compiling the main
873 ; expression we need to make sure all globals for symbols used during the
874 ; compilation are created using the generate-ensure-global function.
876 (define (compile-tree-il expr env opts)
878 (with-fluids ((bindings-data (make-bindings))
879 (disable-void-check '())
880 (always-lexical '()))
881 (process-options! opts)
882 (let ((loc (location expr))
883 (compiled (compile-expr expr)))
885 `(,@(map-globals-needed (fluid-ref bindings-data)
887 (generate-ensure-global loc sym mod)))