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))
30 ;;; Certain common parameters (like the bindings data structure or
31 ;;; compiler options) are not always passed around but accessed using
32 ;;; fluids to simulate dynamic binding (hey, this is about elisp).
34 ;;; The bindings data structure to keep track of symbol binding related
37 (define bindings-data (make-fluid))
39 ;;; Store for which symbols (or all/none) void checks are disabled.
41 (define disable-void-check (make-fluid))
43 ;;; Store which symbols (or all/none) should always be bound lexically,
44 ;;; even with ordinary let and as lambda arguments.
46 (define always-lexical (make-fluid))
48 ;;; Find the source properties of some parsed expression if there are
49 ;;; any associated with it.
53 (let ((props (source-properties x)))
54 (and (not (null? props))
57 ;;; Values to use for Elisp's nil and t.
59 (define (nil-value loc)
60 (make-const loc (@ (language elisp runtime) nil-value)))
63 (make-const loc (@ (language elisp runtime) t-value)))
65 ;;; Modules that contain the value and function slot bindings.
67 (define runtime '(language elisp runtime))
69 (define macro-slot '(language elisp runtime macro-slot))
71 (define value-slot (@ (language elisp runtime) value-slot-module))
73 (define function-slot (@ (language elisp runtime) function-slot-module))
75 ;;; The backquoting works the same as quasiquotes in Scheme, but the
76 ;;; forms are named differently; to make easy adaptions, we define these
77 ;;; predicates checking for a symbol being the car of an
78 ;;; unquote/unquote-splicing/backquote form.
80 (define (backquote? sym)
81 (and (symbol? sym) (eq? sym '\`)))
83 (define (unquote? sym)
84 (and (symbol? sym) (eq? sym '\,)))
86 (define (unquote-splicing? sym)
87 (and (symbol? sym) (eq? sym '\,@)))
89 ;;; Build a call to a primitive procedure nicely.
91 (define (call-primitive loc sym . args)
92 (make-application loc (make-primitive-ref loc sym) args))
94 ;;; Error reporting routine for syntax/compilation problems or build
95 ;;; code for a runtime-error output.
97 (define (report-error loc . args)
100 (define (runtime-error loc msg . args)
101 (make-application loc
102 (make-primitive-ref loc 'error)
103 (cons (make-const loc msg) args)))
105 ;;; Generate code to ensure a global symbol is there for further use of
106 ;;; a given symbol. In general during the compilation, those needed are
107 ;;; only tracked with the bindings data structure. Afterwards, however,
108 ;;; for all those needed symbols the globals are really generated with
111 (define (generate-ensure-global loc sym module)
112 (make-application loc
113 (make-module-ref loc runtime 'ensure-fluid! #t)
114 (list (make-const loc module)
115 (make-const loc sym))))
117 ;;; See if we should do a void-check for a given variable. That means,
118 ;;; check that this check is not disabled via the compiler options for
119 ;;; this symbol. Disabling of void check is only done for the value-slot
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))))))
128 ;;; Build a construct that establishes dynamic bindings for certain
129 ;;; variables. We may want to choose between binding with fluids and
130 ;;; with-fluids* and using just ordinary module symbols and
131 ;;; setting/reverting their values with a dynamic-wind.
133 (define (let-dynamic loc syms module vals body)
137 (make-application loc
138 (make-primitive-ref loc 'list)
140 (make-module-ref loc module sym #t))
142 (make-application loc (make-primitive-ref loc 'list) vals)
145 (make-lambda-case #f '() #f #f #f '() '() body #f))))
147 ;;; Handle access to a variable (reference/setting) correctly depending
148 ;;; on whether it is currently lexically or dynamically bound. lexical
149 ;;; access is done only for references to the value-slot module!
151 (define (access-variable loc sym module handle-lexical handle-dynamic)
152 (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
153 (if (and lexical (equal? module value-slot))
154 (handle-lexical lexical)
157 ;;; Generate code to reference a variable. For references in the
158 ;;; value-slot module, we may want to generate a lexical reference
159 ;;; instead if the variable has a lexical binding.
161 (define (reference-variable loc sym module)
166 (lambda (lexical) (make-lexical-ref loc lexical lexical))
168 (mark-global-needed! (fluid-ref bindings-data) sym module)
171 (make-module-ref loc module sym #t)))))
173 ;;; Reference a variable and error if the value is void.
175 (define (reference-with-check loc sym module)
176 (if (want-void-check? sym module)
177 (let ((var (gensym)))
182 `(,(reference-variable loc sym module))
187 (make-module-ref loc runtime 'void #t)
188 (make-lexical-ref loc 'value var))
189 (runtime-error loc "variable is void:" (make-const loc sym))
190 (make-lexical-ref loc 'value var))))
191 (reference-variable loc sym module)))
193 ;;; Generate code to set a variable. Just as with reference-variable, in
194 ;;; case of a reference to value-slot, we want to generate a lexical set
195 ;;; when the variable has a lexical binding.
197 (define (set-variable! loc sym module value)
202 (lambda (lexical) (make-lexical-set loc lexical lexical value))
204 (mark-global-needed! (fluid-ref bindings-data) sym module)
207 (make-module-ref loc module sym #t)
210 ;;; Process the bindings part of a let or let* expression; that is,
211 ;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
214 (define (process-let-bindings loc bindings)
219 (if (or (not (list? b))
220 (not (= (length b) 2)))
223 "expected symbol or list of 2 elements in let")
224 (if (not (symbol? (car b)))
225 (report-error loc "expected symbol in let")
226 (cons (car b) (cadr b))))))
229 ;;; Split the let bindings into a list to be done lexically and one
230 ;;; dynamically. A symbol will be bound lexically if and only if: We're
231 ;;; processing a lexical-let (i.e. module is 'lexical), OR we're
232 ;;; processing a value-slot binding AND the symbol is already lexically
233 ;;; bound or it is always lexical.
235 (define (bind-lexically? sym module)
236 (or (eq? module 'lexical)
237 (and (equal? module value-slot)
238 (let ((always (fluid-ref always-lexical)))
239 (or (eq? always 'all)
241 (get-lexical-binding (fluid-ref bindings-data) sym))))))
243 (define (split-let-bindings bindings module)
244 (let iterate ((tail bindings)
248 (values (reverse lexical) (reverse dynamic))
249 (if (bind-lexically? (caar tail) module)
250 (iterate (cdr tail) (cons (car tail) lexical) dynamic)
251 (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
253 ;;; Compile let and let* expressions. The code here is used both for
254 ;;; let/let* and flet/flet*, just with a different bindings module.
256 ;;; A special module value 'lexical means that we're doing a lexical-let
257 ;;; instead and the bindings should not be saved to globals at all but
258 ;;; be done with the lexical framework instead.
260 ;;; Let is done with a single call to let-dynamic binding them locally
261 ;;; to new values all "at once". If there is at least one variable to
262 ;;; bind lexically among the bindings, we first do a let for all of them
263 ;;; to evaluate all values before any bindings take place, and then call
264 ;;; let-dynamic for the variables to bind dynamically.
266 (define (generate-let loc module bindings body)
267 (let ((bind (process-let-bindings loc bindings)))
269 (lambda () (split-let-bindings bind module))
270 (lambda (lexical dynamic)
271 (for-each (lambda (sym)
272 (mark-global-needed! (fluid-ref bindings-data)
276 (let ((make-values (lambda (for)
277 (map (lambda (el) (compile-expr (cdr el)))
279 (make-body (lambda ()
280 (make-sequence loc (map compile-expr body)))))
282 (let-dynamic loc (map car dynamic) module
283 (make-values dynamic) (make-body))
284 (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
285 (dynamic-syms (map (lambda (el) (gensym)) dynamic))
286 (all-syms (append lexical-syms dynamic-syms))
287 (vals (append (make-values lexical)
288 (make-values dynamic))))
293 (with-lexical-bindings
294 (fluid-ref bindings-data)
295 (map car lexical) lexical-syms
304 (make-lexical-ref loc
308 (make-body)))))))))))))
310 ;;; Let* is compiled to a cascaded set of "small lets" for each binding
311 ;;; in turn so that each one already sees the preceding bindings.
313 (define (generate-let* loc module bindings body)
314 (let ((bind (process-let-bindings loc bindings)))
316 (for-each (lambda (sym)
317 (if (not (bind-lexically? sym module))
318 (mark-global-needed! (fluid-ref bindings-data)
322 (let iterate ((tail bind))
324 (make-sequence loc (map compile-expr body))
325 (let ((sym (caar tail))
326 (value (compile-expr (cdar tail))))
327 (if (bind-lexically? sym module)
328 (let ((target (gensym)))
333 (with-lexical-bindings
334 (fluid-ref bindings-data)
337 (lambda () (iterate (cdr tail))))))
342 (iterate (cdr tail))))))))))
344 ;;; Split the argument list of a lambda expression into required,
345 ;;; optional and rest arguments and also check it is actually valid.
346 ;;; Additionally, we create a list of all "local variables" (that is,
347 ;;; required, optional and rest arguments together) and also this one
348 ;;; split into those to be bound lexically and dynamically. Returned is
349 ;;; as multiple values: required optional rest lexical dynamic
351 (define (bind-arg-lexical? arg)
352 (let ((always (fluid-ref always-lexical)))
353 (or (eq? always 'all)
356 (define (split-lambda-arguments loc args)
357 (let iterate ((tail args)
365 (let ((final-required (reverse required))
366 (final-optional (reverse optional))
367 (final-lexical (reverse lexical))
368 (final-dynamic (reverse dynamic)))
369 (values final-required
374 ((and (eq? mode 'required)
375 (eq? (car tail) '&optional))
376 (iterate (cdr tail) 'optional required optional lexical dynamic))
377 ((eq? (car tail) '&rest)
378 (if (or (null? (cdr tail))
379 (not (null? (cddr tail))))
380 (report-error loc "expected exactly one symbol after &rest")
381 (let* ((rest (cadr tail))
382 (rest-lexical (bind-arg-lexical? rest))
383 (final-required (reverse required))
384 (final-optional (reverse optional))
385 (final-lexical (reverse (if rest-lexical
388 (final-dynamic (reverse (if rest-lexical
390 (cons rest dynamic)))))
391 (values final-required
397 (if (not (symbol? (car tail)))
399 "expected symbol in argument list, got"
401 (let* ((arg (car tail))
402 (bind-lexical (bind-arg-lexical? arg))
403 (new-lexical (if bind-lexical
406 (new-dynamic (if bind-lexical
408 (cons arg dynamic))))
410 ((required) (iterate (cdr tail) mode
411 (cons arg required) optional
412 new-lexical new-dynamic))
413 ((optional) (iterate (cdr tail) mode
414 required (cons arg optional)
415 new-lexical new-dynamic))
417 (error "invalid mode in split-lambda-arguments"
420 ;;; Compile a lambda expression. Things get a little complicated because
421 ;;; TreeIL does not allow optional arguments but only one rest argument,
422 ;;; and also the rest argument should be nil instead of '() for no
423 ;;; values given. Because of this, we have to do a little preprocessing
424 ;;; to get everything done before the real body is called.
426 ;;; (lambda (a &optional b &rest c) body) should become:
427 ;;; (lambda (a_ . rest_)
428 ;;; (with-fluids* (list a b c) (list a_ nil nil)
430 ;;; (if (not (null? rest_))
432 ;;; (fluid-set! b (car rest_))
433 ;;; (set! rest_ (cdr rest_))
434 ;;; (if (not (null? rest_))
435 ;;; (fluid-set! c rest_))))
438 ;;; This is formulated very imperatively, but I think in this case that
439 ;;; is quite clear and better than creating a lot of nested let's.
441 ;;; Another thing we have to be aware of is that lambda arguments are
442 ;;; usually dynamically bound, even when a lexical binding is in tact
443 ;;; for a symbol. For symbols that are marked as 'always lexical'
444 ;;; however, we bind them here lexically, too -- and thus we get them
445 ;;; out of the let-dynamic call and register a lexical binding for them
446 ;;; (the lexical target variable is already there, namely the real
447 ;;; lambda argument from TreeIL). For optional arguments that are
448 ;;; lexically bound we need to create the lexical bindings though with
449 ;;; an additional let, as those arguments are not part of the ordinary
452 (define (compile-lambda loc args body)
453 (if (not (list? args))
454 (report-error loc "expected list for argument-list" args))
456 (report-error loc "function body might not be empty"))
459 (split-lambda-arguments loc args))
460 (lambda (required optional rest lexical dynamic)
461 (let* ((make-sym (lambda (sym) (gensym)))
462 (required-sym (map make-sym required))
463 (required-pairs (map cons required required-sym))
464 (have-real-rest (or rest (not (null? optional))))
465 (rest-sym (if have-real-rest (gensym) '()))
466 (rest-name (if rest rest rest-sym))
467 (rest-lexical (and rest (memq rest lexical)))
468 (rest-dynamic (and rest (not rest-lexical)))
469 (real-args (append required-sym rest-sym))
470 (arg-names (append required rest-name))
471 (lex-optionals (lset-intersection eq? optional lexical))
472 (dyn-optionals (lset-intersection eq? optional dynamic))
473 (optional-sym (map make-sym lex-optionals))
474 (optional-lex-pairs (map cons lex-optionals optional-sym))
475 (find-required-pairs (lambda (filter)
477 (lambda (name-sym el)
478 (eq? (car name-sym) el))
481 (required-lex-pairs (find-required-pairs lexical))
482 (rest-pair (if rest-lexical `((,rest . ,rest-sym)) '()))
483 (all-lex-pairs (append required-lex-pairs
486 (for-each (lambda (sym)
487 (mark-global-needed! (fluid-ref bindings-data)
491 (with-dynamic-bindings
492 (fluid-ref bindings-data)
495 (with-lexical-bindings
496 (fluid-ref bindings-data)
497 (map car all-lex-pairs)
498 (map cdr all-lex-pairs)
506 (if have-real-rest rest-name #f)
510 (append required-sym (list rest-sym))
513 (map (lambda (name-sym)
518 (find-required-pairs dynamic)))
520 (map (lambda (sym) (nil-value loc))
522 `(,@dyn-optionals ,rest-sym)
524 (init (append init-req init-nils))
528 `(,(process-optionals loc
536 ,@(map compile-expr body))))
537 (dynlet (let-dynamic loc
542 (full-body (if (null? dynamic)
545 (if (null? optional-sym)
556 ;;; Build the code to handle setting of optional arguments that are
557 ;;; present and updating the rest list.
559 (define (process-optionals loc optional rest-name rest-sym)
560 (let iterate ((tail optional))
567 (make-lexical-ref loc rest-name rest-sym))
571 (list (set-variable! loc
587 (make-lexical-ref loc rest-name rest-sym)))
588 (iterate (cdr tail))))))))
590 ;;; This builds the code to set the rest variable to nil if it is empty.
592 (define (process-rest loc rest rest-name rest-sym)
593 (let ((rest-empty (call-primitive loc
595 (make-lexical-ref loc
600 (make-conditional loc
606 (make-lexical-ref loc
609 ((not (null? rest-sym))
610 (make-conditional loc rest-empty
614 "too many arguments and no rest argument")))
615 (else (make-void loc)))))
617 ;;; Handle the common part of defconst and defvar, that is, checking for
618 ;;; a correct doc string and arguments as well as maybe in the future
619 ;;; handling the docstring somehow.
621 (define (handle-var-def loc sym doc)
623 ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
624 ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
625 ((and (not (null? doc)) (not (string? (car doc))))
626 (report-error loc "expected string as third argument of defvar, got"
628 ;; TODO: Handle doc string if present.
631 ;;; Handle macro bindings.
633 (define (is-macro? sym)
634 (module-defined? (resolve-interface macro-slot) sym))
636 (define (define-macro! loc sym definition)
637 (let ((resolved (resolve-module macro-slot)))
639 (report-error loc "macro is already defined" sym)
641 (module-define! resolved sym definition)
642 (module-export! resolved (list sym))))))
644 (define (get-macro sym)
645 (module-ref (resolve-module macro-slot) sym))
647 ;;; See if a (backquoted) expression contains any unquotes.
649 (define (contains-unquotes? expr)
651 (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
653 (or (contains-unquotes? (car expr))
654 (contains-unquotes? (cdr expr))))
657 ;;; Process a backquoted expression by building up the needed
658 ;;; cons/append calls. For splicing, it is assumed that the expression
659 ;;; spliced in evaluates to a list. The emacs manual does not really
660 ;;; state either it has to or what to do if it does not, but Scheme
661 ;;; explicitly forbids it and this seems reasonable also for elisp.
663 (define (unquote-cell? expr)
664 (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
666 (define (unquote-splicing-cell? expr)
667 (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
669 (define (process-backquote loc expr)
670 (if (contains-unquotes? expr)
672 (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
673 (compile-expr (cadr expr))
674 (let* ((head (car expr))
675 (processed-tail (process-backquote loc (cdr expr)))
676 (head-is-list-2 (and (list? head)
677 (= (length head) 2)))
678 (head-unquote (and head-is-list-2
679 (unquote? (car head))))
680 (head-unquote-splicing (and head-is-list-2
683 (if head-unquote-splicing
686 (compile-expr (cadr head))
688 (call-primitive loc 'cons
690 (compile-expr (cadr head))
691 (process-backquote loc head))
694 "non-pair expression contains unquotes"
696 (make-const loc expr)))
698 ;;; Temporarily update a list of symbols that are handled specially
699 ;;; (disabled void check or always lexical) for compiling body. We need
700 ;;; to handle special cases for already all / set to all and the like.
702 (define (with-added-symbols loc fluid syms body)
704 (report-error loc "symbol-list construct has empty body"))
705 (if (not (or (eq? syms 'all)
706 (and (list? syms) (and-map symbol? syms))))
707 (report-error loc "invalid symbol list" syms))
708 (let ((old (fluid-ref fluid))
709 (make-body (lambda ()
710 (make-sequence loc (map compile-expr body)))))
713 (let ((new (if (eq? syms 'all)
716 (with-fluids ((fluid new))
719 ;;; Compile a symbol expression. This is a variable reference or maybe
720 ;;; some special value like nil.
722 (define (compile-symbol loc sym)
724 ((nil) (nil-value loc))
726 (else (reference-with-check loc sym value-slot))))
728 ;;; Compile a pair-expression (that is, any structure-like construct).
730 (define (compile-pair loc expr)
733 (make-sequence loc (map compile-expr forms)))
735 ((if ,condition ,ifclause)
736 (make-conditional loc
737 (compile-expr condition)
738 (compile-expr ifclause)
741 ((if ,condition ,ifclause ,elseclause)
742 (make-conditional loc
743 (compile-expr condition)
744 (compile-expr ifclause)
745 (compile-expr elseclause)))
747 ((if ,condition ,ifclause . ,elses)
748 (make-conditional loc
749 (compile-expr condition)
750 (compile-expr ifclause)
751 (make-sequence loc (map compile-expr elses))))
753 ;; defconst and defvar are kept here in the compiler (rather than
754 ;; doing them as macros) for if we may want to handle the docstring
757 ((defconst ,sym ,value . ,doc)
758 (if (handle-var-def loc sym doc)
760 (list (set-variable! loc
763 (compile-expr value))
764 (make-const loc sym)))))
766 ((defvar ,sym) (make-const loc sym))
768 ((defvar ,sym ,value . ,doc)
769 (if (handle-var-def loc sym doc)
772 (list (make-conditional
776 (make-module-ref loc runtime 'void #t)
777 (reference-variable loc sym value-slot))
778 (set-variable! loc sym value-slot (compile-expr value))
780 (make-const loc sym)))))
782 ;; Build a set form for possibly multiple values. The code is not
783 ;; formulated tail recursive because it is clearer this way and
784 ;; large lists of symbol expression pairs are very unlikely.
786 ((setq . ,args) (guard (not (null? args)))
789 (let iterate ((tail args))
790 (let ((sym (car tail))
791 (tailtail (cdr tail)))
792 (if (not (symbol? sym))
793 (report-error loc "expected symbol in setq")
796 "missing value for symbol in setq"
798 (let* ((val (compile-expr (car tailtail)))
799 (op (set-variable! loc sym value-slot val)))
800 (if (null? (cdr tailtail))
801 (let* ((temp (gensym))
802 (ref (make-lexical-ref loc temp temp)))
810 (list (set-variable! loc
815 (cons (set-variable! loc sym value-slot val)
816 (iterate (cdr tailtail)))))))))))
818 ;; All lets (let, flet, lexical-let and let* forms) are done using
819 ;; the generate-let/generate-let* methods.
821 ((let ,bindings . ,body) (guard (and (list? bindings)
822 (not (null? bindings))
824 (generate-let loc value-slot bindings body))
826 ((lexical-let ,bindings . ,body) (guard (and (list? bindings)
827 (not (null? bindings))
829 (generate-let loc 'lexical bindings body))
831 ((flet ,bindings . ,body) (guard (and (list? bindings)
832 (not (null? bindings))
834 (generate-let loc function-slot bindings body))
836 ((let* ,bindings . ,body) (guard (and (list? bindings)
837 (not (null? bindings))
839 (generate-let* loc value-slot bindings body))
841 ((lexical-let* ,bindings . ,body) (guard (and (list? bindings)
842 (not (null? bindings))
844 (generate-let* loc 'lexical bindings body))
846 ((flet* ,bindings . ,body) (guard (and (list? bindings)
847 (not (null? bindings))
849 (generate-let* loc function-slot bindings body))
851 ;; Temporarily disable void checks or set symbols as always lexical
852 ;; only for the lexical scope of a construct.
854 ((without-void-checks ,syms . ,body)
855 (with-added-symbols loc disable-void-check syms body))
857 ((with-always-lexical ,syms . ,body)
858 (with-added-symbols loc always-lexical syms body))
860 ;; guile-ref allows building TreeIL's module references from within
861 ;; elisp as a way to access data within the Guile universe. The
862 ;; module and symbol referenced are static values, just like (@
863 ;; module symbol) does!
865 ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym)))
866 (make-module-ref loc module sym #t))
868 ;; guile-primitive allows to create primitive references, which are
869 ;; still a little faster.
871 ((guile-primitive ,sym) (guard (symbol? sym))
872 (make-primitive-ref loc sym))
874 ;; A while construct is transformed into a tail-recursive loop like
877 ;; (letrec ((iterate (lambda ()
884 ;; As letrec is not directly accessible from elisp, while is
885 ;; implemented here instead of with a macro.
887 ((while ,condition . ,body)
888 (let* ((itersym (gensym))
889 (compiled-body (map compile-expr body))
890 (iter-call (make-application loc
891 (make-lexical-ref loc
895 (full-body (make-sequence loc
896 `(,@compiled-body ,iter-call)))
897 (lambda-body (make-conditional loc
898 (compile-expr condition)
901 (iter-thunk (make-lambda loc
919 ;; Either (lambda ...) or (function (lambda ...)) denotes a
920 ;; lambda-expression that should be compiled.
922 ((lambda ,args . ,body)
923 (compile-lambda loc args body))
925 ((function (lambda ,args . ,body))
926 (compile-lambda loc args body))
928 ;; Build a lambda and also assign it to the function cell of some
929 ;; symbol. This is no macro as we might want to honour the docstring
930 ;; at some time; just as with defvar/defconst.
932 ((defun ,name ,args . ,body)
933 (if (not (symbol? name))
934 (report-error loc "expected symbol as function name" name)
936 (list (set-variable! loc
942 (make-const loc name)))))
944 ;; Define a macro (this is done directly at compile-time!). FIXME:
945 ;; Recursive macros don't work!
947 ((defmacro ,name ,args . ,body)
948 (if (not (symbol? name))
949 (report-error loc "expected symbol as macro name" name)
950 (let* ((tree-il (with-fluids ((bindings-data (make-bindings)))
951 (compile-lambda loc args body)))
952 (object (compile tree-il #:from 'tree-il #:to 'value)))
953 (define-macro! loc name object)
954 (make-const loc name))))
956 ;; XXX: Maybe we could implement backquotes in macros, too.
958 ((,backq ,val) (guard (backquote? backq))
959 (process-backquote loc val))
961 ;; XXX: Why do we need 'quote here instead of quote?
964 (make-const loc val))
966 ;; Macro calls are simply expanded and recursively compiled.
968 ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro)))
969 (let ((expander (get-macro macro)))
970 (compile-expr (apply expander args))))
972 ;; Function calls using (function args) standard notation; here, we
973 ;; have to take the function value of a symbol if it is one. It
974 ;; seems that functions in form of uncompiled lists are not
975 ;; supported in this syntax, so we don't have to care for them.
978 (make-application loc
980 (reference-with-check loc func function-slot)
982 (map compile-expr args)))
985 (report-error loc "unrecognized elisp" expr))))
987 ;;; Compile a single expression to TreeIL.
989 (define (compile-expr expr)
990 (let ((loc (location expr)))
993 (compile-symbol loc expr))
995 (compile-pair loc expr))
996 (else (make-const loc expr)))))
998 ;;; Process the compiler options.
999 ;;; FIXME: Why is '(()) passed as options by the REPL?
1001 (define (valid-symbol-list-arg? value)
1002 (or (eq? value 'all)
1003 (and (list? value) (and-map symbol? value))))
1005 (define (process-options! opt)
1006 (if (and (not (null? opt))
1007 (not (equal? opt '(()))))
1008 (if (null? (cdr opt))
1009 (report-error #f "Invalid compiler options" opt)
1010 (let ((key (car opt))
1013 ((#:disable-void-check)
1014 (if (valid-symbol-list-arg? value)
1015 (fluid-set! disable-void-check value)
1017 "Invalid value for #:disable-void-check"
1020 (if (valid-symbol-list-arg? value)
1021 (fluid-set! always-lexical value)
1023 "Invalid value for #:always-lexical"
1025 (else (report-error #f
1026 "Invalid compiler option"
1029 ;;; Entry point for compilation to TreeIL. This creates the bindings
1030 ;;; data structure, and after compiling the main expression we need to
1031 ;;; make sure all globals for symbols used during the compilation are
1032 ;;; created using the generate-ensure-global function.
1034 (define (compile-tree-il expr env opts)
1036 (with-fluids ((bindings-data (make-bindings))
1037 (disable-void-check '())
1038 (always-lexical '()))
1039 (process-options! opts)
1040 (let ((loc (location expr))
1041 (compiled (compile-expr expr)))
1043 `(,@(map-globals-needed
1044 (fluid-ref bindings-data)
1046 (generate-ensure-global loc sym mod)))