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 #:use-module (srfi srfi-8)
29 #:use-module (srfi srfi-11)
30 #:use-module (srfi srfi-26)
31 #:export (compile-tree-il))
33 ;;; Certain common parameters (like the bindings data structure or
34 ;;; compiler options) are not always passed around but accessed using
35 ;;; fluids to simulate dynamic binding (hey, this is about elisp).
37 ;;; The bindings data structure to keep track of symbol binding related
40 (define bindings-data (make-fluid))
42 ;;; Store for which symbols (or all/none) void checks are disabled.
44 (define disable-void-check (make-fluid))
46 ;;; Store which symbols (or all/none) should always be bound lexically,
47 ;;; even with ordinary let and as lambda arguments.
49 (define always-lexical (make-fluid))
51 ;;; Find the source properties of some parsed expression if there are
52 ;;; any associated with it.
56 (let ((props (source-properties x)))
57 (and (not (null? props))
60 ;;; Values to use for Elisp's nil and t.
62 (define (nil-value loc)
63 (make-const loc (@ (language elisp runtime) nil-value)))
66 (make-const loc (@ (language elisp runtime) t-value)))
68 ;;; Modules that contain the value and function slot bindings.
70 (define runtime '(language elisp runtime))
72 (define value-slot (@ (language elisp runtime) value-slot-module))
74 (define function-slot (@ (language elisp runtime) function-slot-module))
76 ;;; The backquoting works the same as quasiquotes in Scheme, but the
77 ;;; forms are named differently; to make easy adaptions, we define these
78 ;;; predicates checking for a symbol being the car of an
79 ;;; unquote/unquote-splicing/backquote form.
81 (define (backquote? sym)
82 (and (symbol? sym) (eq? sym '\`)))
84 (define (unquote? sym)
85 (and (symbol? sym) (eq? sym '\,)))
87 (define (unquote-splicing? sym)
88 (and (symbol? sym) (eq? sym '\,@)))
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))
95 ;;; Error reporting routine for syntax/compilation problems or build
96 ;;; code for a runtime-error output.
98 (define (report-error loc . args)
101 (define (runtime-error loc msg . args)
102 (make-application loc
103 (make-primitive-ref loc 'error)
104 (cons (make-const loc msg) args)))
106 ;;; Generate code to ensure a global symbol is there for further use of
107 ;;; a given symbol. In general during the compilation, those needed are
108 ;;; only tracked with the bindings data structure. Afterwards, however,
109 ;;; for all those needed symbols the globals are really generated with
112 (define (generate-ensure-global loc sym module)
113 (make-application loc
114 (make-module-ref loc runtime 'ensure-fluid! #t)
115 (list (make-const loc module)
116 (make-const loc sym))))
118 ;;; See if we should do a void-check for a given variable. That means,
119 ;;; check that this check is not disabled via the compiler options for
120 ;;; this symbol. Disabling of void check is only done for the value-slot
123 (define (want-void-check? sym module)
124 (let ((disabled (fluid-ref disable-void-check)))
125 (or (not (equal? module value-slot))
126 (and (not (eq? disabled 'all))
127 (not (memq sym disabled))))))
129 ;;; Build a construct that establishes dynamic bindings for certain
130 ;;; variables. We may want to choose between binding with fluids and
131 ;;; with-fluids* and using just ordinary module symbols and
132 ;;; setting/reverting their values with a dynamic-wind.
134 (define (let-dynamic loc syms module vals body)
138 (make-application loc
139 (make-primitive-ref loc 'list)
141 (make-module-ref loc module sym #t))
143 (make-application loc (make-primitive-ref loc 'list) vals)
146 (make-lambda-case #f '() #f #f #f '() '() body #f))))
148 ;;; Handle access to a variable (reference/setting) correctly depending
149 ;;; on whether it is currently lexically or dynamically bound. lexical
150 ;;; access is done only for references to the value-slot module!
152 (define (access-variable loc sym module handle-lexical handle-dynamic)
153 (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
154 (if (and lexical (equal? module value-slot))
155 (handle-lexical lexical)
158 ;;; Generate code to reference a variable. For references in the
159 ;;; value-slot module, we may want to generate a lexical reference
160 ;;; instead if the variable has a lexical binding.
162 (define (reference-variable loc sym module)
167 (lambda (lexical) (make-lexical-ref loc lexical lexical))
169 (mark-global-needed! (fluid-ref bindings-data) sym module)
172 (make-module-ref loc module sym #t)))))
174 ;;; Reference a variable and error if the value is void.
176 (define (reference-with-check loc sym module)
177 (if (want-void-check? sym module)
178 (let ((var (gensym)))
183 `(,(reference-variable loc sym module))
188 (make-module-ref loc runtime 'void #t)
189 (make-lexical-ref loc 'value var))
190 (runtime-error loc "variable is void:" (make-const loc sym))
191 (make-lexical-ref loc 'value var))))
192 (reference-variable loc sym module)))
194 ;;; Generate code to set a variable. Just as with reference-variable, in
195 ;;; case of a reference to value-slot, we want to generate a lexical set
196 ;;; when the variable has a lexical binding.
198 (define (set-variable! loc sym module value)
203 (lambda (lexical) (make-lexical-set loc lexical lexical value))
205 (mark-global-needed! (fluid-ref bindings-data) sym module)
208 (make-module-ref loc module sym #t)
211 ;;; Process the bindings part of a let or let* expression; that is,
212 ;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
215 (define (process-let-bindings loc bindings)
220 (if (or (not (list? b))
221 (not (= (length b) 2)))
224 "expected symbol or list of 2 elements in let")
225 (if (not (symbol? (car b)))
226 (report-error loc "expected symbol in let")
227 (cons (car b) (cadr b))))))
230 ;;; Split the let bindings into a list to be done lexically and one
231 ;;; dynamically. A symbol will be bound lexically if and only if: We're
232 ;;; processing a lexical-let (i.e. module is 'lexical), OR we're
233 ;;; processing a value-slot binding AND the symbol is already lexically
234 ;;; bound or it is always lexical.
236 (define (bind-lexically? sym module)
237 (or (eq? module 'lexical)
238 (and (equal? module value-slot)
239 (let ((always (fluid-ref always-lexical)))
240 (or (eq? always 'all)
242 (get-lexical-binding (fluid-ref bindings-data) sym))))))
244 (define (split-let-bindings bindings module)
245 (let iterate ((tail bindings)
249 (values (reverse lexical) (reverse dynamic))
250 (if (bind-lexically? (caar tail) module)
251 (iterate (cdr tail) (cons (car tail) lexical) dynamic)
252 (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
254 ;;; Compile let and let* expressions. The code here is used both for
255 ;;; let/let* and flet/flet*, just with a different bindings module.
257 ;;; A special module value 'lexical means that we're doing a lexical-let
258 ;;; instead and the bindings should not be saved to globals at all but
259 ;;; be done with the lexical framework instead.
261 ;;; Let is done with a single call to let-dynamic binding them locally
262 ;;; to new values all "at once". If there is at least one variable to
263 ;;; bind lexically among the bindings, we first do a let for all of them
264 ;;; to evaluate all values before any bindings take place, and then call
265 ;;; let-dynamic for the variables to bind dynamically.
267 (define (generate-let loc module bindings body)
268 (let ((bind (process-let-bindings loc bindings)))
270 (lambda () (split-let-bindings bind module))
271 (lambda (lexical dynamic)
272 (for-each (lambda (sym)
273 (mark-global-needed! (fluid-ref bindings-data)
277 (let ((make-values (lambda (for)
278 (map (lambda (el) (compile-expr (cdr el)))
280 (make-body (lambda ()
281 (make-sequence loc (map compile-expr body)))))
283 (let-dynamic loc (map car dynamic) module
284 (make-values dynamic) (make-body))
285 (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
286 (dynamic-syms (map (lambda (el) (gensym)) dynamic))
287 (all-syms (append lexical-syms dynamic-syms))
288 (vals (append (make-values lexical)
289 (make-values dynamic))))
294 (with-lexical-bindings
295 (fluid-ref bindings-data)
296 (map car lexical) lexical-syms
305 (make-lexical-ref loc
309 (make-body)))))))))))))
311 ;;; Let* is compiled to a cascaded set of "small lets" for each binding
312 ;;; in turn so that each one already sees the preceding bindings.
314 (define (generate-let* loc module bindings body)
315 (let ((bind (process-let-bindings loc bindings)))
317 (for-each (lambda (sym)
318 (if (not (bind-lexically? sym module))
319 (mark-global-needed! (fluid-ref bindings-data)
323 (let iterate ((tail bind))
325 (make-sequence loc (map compile-expr body))
326 (let ((sym (caar tail))
327 (value (compile-expr (cdar tail))))
328 (if (bind-lexically? sym module)
329 (let ((target (gensym)))
334 (with-lexical-bindings
335 (fluid-ref bindings-data)
338 (lambda () (iterate (cdr tail))))))
343 (iterate (cdr tail))))))))))
345 ;;; Split the argument list of a lambda expression into required,
346 ;;; optional and rest arguments and also check it is actually valid.
347 ;;; Additionally, we create a list of all "local variables" (that is,
348 ;;; required, optional and rest arguments together) and also this one
349 ;;; split into those to be bound lexically and dynamically. Returned is
350 ;;; as multiple values: required optional rest lexical dynamic
352 (define (bind-arg-lexical? arg)
353 (let ((always (fluid-ref always-lexical)))
354 (or (eq? always 'all)
357 (define (split-lambda-arguments loc args)
358 (let iterate ((tail args)
366 (let ((final-required (reverse required))
367 (final-optional (reverse optional))
368 (final-lexical (reverse lexical))
369 (final-dynamic (reverse dynamic)))
370 (values final-required
375 ((and (eq? mode 'required)
376 (eq? (car tail) '&optional))
377 (iterate (cdr tail) 'optional required optional lexical dynamic))
378 ((eq? (car tail) '&rest)
379 (if (or (null? (cdr tail))
380 (not (null? (cddr tail))))
381 (report-error loc "expected exactly one symbol after &rest")
382 (let* ((rest (cadr tail))
383 (rest-lexical (bind-arg-lexical? rest))
384 (final-required (reverse required))
385 (final-optional (reverse optional))
386 (final-lexical (reverse (if rest-lexical
389 (final-dynamic (reverse (if rest-lexical
391 (cons rest dynamic)))))
392 (values final-required
398 (if (not (symbol? (car tail)))
400 "expected symbol in argument list, got"
402 (let* ((arg (car tail))
403 (bind-lexical (bind-arg-lexical? arg))
404 (new-lexical (if bind-lexical
407 (new-dynamic (if bind-lexical
409 (cons arg dynamic))))
411 ((required) (iterate (cdr tail) mode
412 (cons arg required) optional
413 new-lexical new-dynamic))
414 ((optional) (iterate (cdr tail) mode
415 required (cons arg optional)
416 new-lexical new-dynamic))
418 (error "invalid mode in split-lambda-arguments"
421 ;;; Compile a lambda expression. One thing we have to be aware of is
422 ;;; that lambda arguments are usually dynamically bound, even when a
423 ;;; lexical binding is intact for a symbol. For symbols that are marked
424 ;;; as 'always lexical,' however, we lexically bind here as well, and
425 ;;; thus we get them out of the let-dynamic call and register a lexical
426 ;;; binding for them (the lexical target variable is already there,
427 ;;; namely the real lambda argument from TreeIL).
429 (define (compile-lambda loc args body)
430 (if (not (list? args))
431 (report-error loc "expected list for argument-list" args))
433 (report-error loc "function body must not be empty"))
434 (receive (required optional rest lexical dynamic)
435 (split-lambda-arguments loc args)
436 (define (process-args args)
437 (define (find-pairs pairs filter)
438 (lset-intersection (lambda (name+sym x)
439 (eq? (car name+sym) x))
442 (let* ((syms (map (lambda (x) (gensym)) args))
443 (pairs (map cons args syms))
444 (lexical-pairs (find-pairs pairs lexical))
445 (dynamic-pairs (find-pairs pairs dynamic)))
446 (values syms pairs lexical-pairs dynamic-pairs)))
447 (let*-values (((required-syms
451 (process-args required))
456 (process-args optional))
457 ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
458 (process-args (if rest (list rest) '())))
459 ((the-rest-sym) (if rest (car rest-syms) #f))
460 ((all-syms) (append required-syms
463 ((all-lex-pairs) (append required-lex-pairs
466 ((all-dyn-pairs) (append required-dyn-pairs
469 (for-each (lambda (sym)
470 (mark-global-needed! (fluid-ref bindings-data)
474 (with-dynamic-bindings
475 (fluid-ref bindings-data)
478 (with-lexical-bindings
479 (fluid-ref bindings-data)
480 (map car all-lex-pairs)
481 (map cdr all-lex-pairs)
492 (map (lambda (x) (nil-value loc)) optional)
495 (make-sequence loc (map compile-expr body))))
504 (make-lexical-ref loc
507 (make-lexical-set loc
518 (map (lambda (name-sym)
527 ;;; Handle the common part of defconst and defvar, that is, checking for
528 ;;; a correct doc string and arguments as well as maybe in the future
529 ;;; handling the docstring somehow.
531 (define (handle-var-def loc sym doc)
533 ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
534 ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
535 ((and (not (null? doc)) (not (string? (car doc))))
536 (report-error loc "expected string as third argument of defvar, got"
538 ;; TODO: Handle doc string if present.
541 ;;; Handle macro bindings.
543 (define (is-macro? sym)
546 (module-defined? (resolve-interface function-slot) sym)
547 (let* ((macro (module-ref (resolve-module function-slot) sym))
548 (macro (if (fluid? macro) (fluid-ref macro) macro)))
549 (and (pair? macro) (eq? (car macro) 'macro)))))
551 (define (define-macro! loc sym definition)
552 (let ((resolved (resolve-module function-slot)))
553 (module-define! resolved sym (cons 'macro definition))
554 (module-export! resolved (list sym))))
556 (define (get-macro sym)
559 (let ((macro (module-ref (resolve-module function-slot) sym)))
560 (cdr (if (fluid? macro) (fluid-ref macro) macro)))))
562 ;;; See if a (backquoted) expression contains any unquotes.
564 (define (contains-unquotes? expr)
566 (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
568 (or (contains-unquotes? (car expr))
569 (contains-unquotes? (cdr expr))))
572 ;;; Process a backquoted expression by building up the needed
573 ;;; cons/append calls. For splicing, it is assumed that the expression
574 ;;; spliced in evaluates to a list. The emacs manual does not really
575 ;;; state either it has to or what to do if it does not, but Scheme
576 ;;; explicitly forbids it and this seems reasonable also for elisp.
578 (define (unquote-cell? expr)
579 (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
581 (define (unquote-splicing-cell? expr)
582 (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
584 (define (process-backquote loc expr)
585 (if (contains-unquotes? expr)
587 (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
588 (compile-expr (cadr expr))
589 (let* ((head (car expr))
590 (processed-tail (process-backquote loc (cdr expr)))
591 (head-is-list-2 (and (list? head)
592 (= (length head) 2)))
593 (head-unquote (and head-is-list-2
594 (unquote? (car head))))
595 (head-unquote-splicing (and head-is-list-2
598 (if head-unquote-splicing
601 (compile-expr (cadr head))
603 (call-primitive loc 'cons
605 (compile-expr (cadr head))
606 (process-backquote loc head))
609 "non-pair expression contains unquotes"
611 (make-const loc expr)))
613 ;;; Temporarily update a list of symbols that are handled specially
614 ;;; (disabled void check or always lexical) for compiling body. We need
615 ;;; to handle special cases for already all / set to all and the like.
617 (define (with-added-symbols loc fluid syms body)
619 (report-error loc "symbol-list construct has empty body"))
620 (if (not (or (eq? syms 'all)
621 (and (list? syms) (and-map symbol? syms))))
622 (report-error loc "invalid symbol list" syms))
623 (let ((old (fluid-ref fluid))
624 (make-body (lambda ()
625 (make-sequence loc (map compile-expr body)))))
628 (let ((new (if (eq? syms 'all)
631 (with-fluids ((fluid new))
634 ;;; Compile a symbol expression. This is a variable reference or maybe
635 ;;; some special value like nil.
637 (define (compile-symbol loc sym)
639 ((nil) (nil-value loc))
641 (else (reference-with-check loc sym value-slot))))
643 ;;; Compile a pair-expression (that is, any structure-like construct).
645 (define (compile-pair loc expr)
648 (make-sequence loc (map compile-expr forms)))
650 ((if ,condition ,ifclause)
651 (make-conditional loc
652 (compile-expr condition)
653 (compile-expr ifclause)
656 ((if ,condition ,ifclause ,elseclause)
657 (make-conditional loc
658 (compile-expr condition)
659 (compile-expr ifclause)
660 (compile-expr elseclause)))
662 ((if ,condition ,ifclause . ,elses)
663 (make-conditional loc
664 (compile-expr condition)
665 (compile-expr ifclause)
666 (make-sequence loc (map compile-expr elses))))
668 ;; defconst and defvar are kept here in the compiler (rather than
669 ;; doing them as macros) for if we may want to handle the docstring
672 ((defconst ,sym ,value . ,doc)
673 (if (handle-var-def loc sym doc)
675 (list (set-variable! loc
678 (compile-expr value))
679 (make-const loc sym)))))
681 ((defvar ,sym) (make-const loc sym))
683 ((defvar ,sym ,value . ,doc)
684 (if (handle-var-def loc sym doc)
687 (list (make-conditional
691 (make-module-ref loc runtime 'void #t)
692 (reference-variable loc sym value-slot))
693 (set-variable! loc sym value-slot (compile-expr value))
695 (make-const loc sym)))))
697 ;; Build a set form for possibly multiple values. The code is not
698 ;; formulated tail recursive because it is clearer this way and
699 ;; large lists of symbol expression pairs are very unlikely.
701 ((setq . ,args) (guard (not (null? args)))
704 (let iterate ((tail args))
705 (let ((sym (car tail))
706 (tailtail (cdr tail)))
707 (if (not (symbol? sym))
708 (report-error loc "expected symbol in setq")
711 "missing value for symbol in setq"
713 (let* ((val (compile-expr (car tailtail)))
714 (op (set-variable! loc sym value-slot val)))
715 (if (null? (cdr tailtail))
716 (let* ((temp (gensym))
717 (ref (make-lexical-ref loc temp temp)))
725 (list (set-variable! loc
730 (cons (set-variable! loc sym value-slot val)
731 (iterate (cdr tailtail)))))))))))
733 ;; All lets (let, flet, lexical-let and let* forms) are done using
734 ;; the generate-let/generate-let* methods.
736 ((let ,bindings . ,body) (guard (and (list? bindings)
737 (not (null? bindings))
739 (generate-let loc value-slot bindings body))
741 ((lexical-let ,bindings . ,body) (guard (and (list? bindings)
742 (not (null? bindings))
744 (generate-let loc 'lexical bindings body))
746 ((flet ,bindings . ,body) (guard (and (list? bindings)
747 (not (null? bindings))
749 (generate-let loc function-slot bindings body))
751 ((let* ,bindings . ,body) (guard (and (list? bindings)
752 (not (null? bindings))
754 (generate-let* loc value-slot bindings body))
756 ((lexical-let* ,bindings . ,body) (guard (and (list? bindings)
757 (not (null? bindings))
759 (generate-let* loc 'lexical bindings body))
761 ((flet* ,bindings . ,body) (guard (and (list? bindings)
762 (not (null? bindings))
764 (generate-let* loc function-slot bindings body))
766 ;; Temporarily disable void checks or set symbols as always lexical
767 ;; only for the lexical scope of a construct.
769 ((without-void-checks ,syms . ,body)
770 (with-added-symbols loc disable-void-check syms body))
772 ((with-always-lexical ,syms . ,body)
773 (with-added-symbols loc always-lexical syms body))
775 ;; guile-ref allows building TreeIL's module references from within
776 ;; elisp as a way to access data within the Guile universe. The
777 ;; module and symbol referenced are static values, just like (@
778 ;; module symbol) does!
780 ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym)))
781 (make-module-ref loc module sym #t))
783 ;; guile-primitive allows to create primitive references, which are
784 ;; still a little faster.
786 ((guile-primitive ,sym) (guard (symbol? sym))
787 (make-primitive-ref loc sym))
789 ;; A while construct is transformed into a tail-recursive loop like
792 ;; (letrec ((iterate (lambda ()
799 ;; As letrec is not directly accessible from elisp, while is
800 ;; implemented here instead of with a macro.
802 ((while ,condition . ,body)
803 (let* ((itersym (gensym))
804 (compiled-body (map compile-expr body))
805 (iter-call (make-application loc
806 (make-lexical-ref loc
810 (full-body (make-sequence loc
811 `(,@compiled-body ,iter-call)))
812 (lambda-body (make-conditional loc
813 (compile-expr condition)
816 (iter-thunk (make-lambda loc
834 ;; Either (lambda ...) or (function (lambda ...)) denotes a
835 ;; lambda-expression that should be compiled.
837 ((lambda ,args . ,body)
838 (compile-lambda loc args body))
840 ((function (lambda ,args . ,body))
841 (compile-lambda loc args body))
843 ;; Build a lambda and also assign it to the function cell of some
844 ;; symbol. This is no macro as we might want to honour the docstring
845 ;; at some time; just as with defvar/defconst.
847 ((defun ,name ,args . ,body)
848 (if (not (symbol? name))
849 (report-error loc "expected symbol as function name" name)
851 (list (set-variable! loc
857 (make-const loc name)))))
859 ;; Define a macro (this is done directly at compile-time!). FIXME:
860 ;; Recursive macros don't work!
862 ((defmacro ,name ,args . ,body)
863 (if (not (symbol? name))
864 (report-error loc "expected symbol as macro name" name)
865 (let* ((tree-il (compile-lambda loc args body))
866 (object (compile tree-il #:from 'tree-il #:to 'value)))
867 (define-macro! loc name object)
868 (make-const loc name))))
870 ;; XXX: Maybe we could implement backquotes in macros, too.
872 ((,backq ,val) (guard (backquote? backq))
873 (process-backquote loc val))
875 ;; XXX: Why do we need 'quote here instead of quote?
878 (make-const loc val))
880 ;; Macro calls are simply expanded and recursively compiled.
882 ((,macro . ,args) (guard (is-macro? macro))
883 (compile-expr (apply (get-macro macro) args)))
885 ;; Function calls using (function args) standard notation; here, we
886 ;; have to take the function value of a symbol if it is one. It
887 ;; seems that functions in form of uncompiled lists are not
888 ;; supported in this syntax, so we don't have to care for them.
891 (make-application loc
893 (reference-with-check loc func function-slot)
895 (map compile-expr args)))
898 (report-error loc "unrecognized elisp" expr))))
900 ;;; Compile a single expression to TreeIL.
902 (define (compile-expr expr)
903 (let ((loc (location expr)))
906 (compile-symbol loc expr))
908 (compile-pair loc expr))
909 (else (make-const loc expr)))))
911 ;;; Process the compiler options.
912 ;;; FIXME: Why is '(()) passed as options by the REPL?
914 (define (valid-symbol-list-arg? value)
916 (and (list? value) (and-map symbol? value))))
918 (define (process-options! opt)
919 (if (and (not (null? opt))
920 (not (equal? opt '(()))))
921 (if (null? (cdr opt))
922 (report-error #f "Invalid compiler options" opt)
923 (let ((key (car opt))
926 ((#:warnings) ; ignore
928 ((#:disable-void-check)
929 (if (valid-symbol-list-arg? value)
930 (fluid-set! disable-void-check value)
932 "Invalid value for #:disable-void-check"
935 (if (valid-symbol-list-arg? value)
936 (fluid-set! always-lexical value)
938 "Invalid value for #:always-lexical"
940 (else (report-error #f
941 "Invalid compiler option"
944 ;;; Entry point for compilation to TreeIL. This creates the bindings
945 ;;; data structure, and after compiling the main expression we need to
946 ;;; make sure all globals for symbols used during the compilation are
947 ;;; created using the generate-ensure-global function.
949 (define (compile-tree-il expr env opts)
951 (with-fluids ((bindings-data (make-bindings))
952 (disable-void-check '())
953 (always-lexical '()))
954 (process-options! opts)
955 (let ((loc (location expr))
956 (compiled (compile-expr expr)))
958 `(,@(map-globals-needed
959 (fluid-ref bindings-data)
961 (generate-ensure-global loc sym mod)))