lexical binding macros
[bpt/guile.git] / module / language / elisp / compile-tree-il.scm
... / ...
CommitLineData
1;;; Guile Emacs Lisp
2
3;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
4
5;; This program is free software; you can redistribute it and/or modify
6;; it under the terms of the GNU General Public License as published by
7;; the Free Software Foundation; either version 3, or (at your option)
8;; any later version.
9;;
10;; This program is distributed in the hope that it will be useful,
11;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13;; GNU General Public License for more details.
14;;
15;; You should have received a copy of the GNU General Public License
16;; along with this program; see the file COPYING. If not, write to
17;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18;; Boston, MA 02111-1307, USA.
19
20;;; Code:
21
22(define-module (language elisp compile-tree-il)
23 #:use-module (language elisp bindings)
24 #:use-module (language elisp runtime)
25 #:use-module (language tree-il)
26 #:use-module (system base pmatch)
27 #:use-module (system base compile)
28 #:use-module (srfi srfi-1)
29 #:use-module (srfi srfi-8)
30 #:use-module (srfi srfi-11)
31 #:use-module (srfi srfi-26)
32 #:export (compile-tree-il
33 compile-progn
34 compile-eval-when-compile
35 compile-if
36 compile-defconst
37 compile-defvar
38 compile-setq
39 compile-let
40 compile-flet
41 compile-labels
42 compile-let*
43 compile-guile-ref
44 compile-guile-primitive
45 compile-function
46 compile-defmacro
47 compile-defun
48 #{compile-`}#
49 compile-quote
50 compile-%funcall
51 compile-%set-lexical-binding-mode))
52
53;;; Certain common parameters (like the bindings data structure or
54;;; compiler options) are not always passed around but accessed using
55;;; fluids to simulate dynamic binding (hey, this is about elisp).
56
57;;; The bindings data structure to keep track of symbol binding related
58;;; data.
59
60(define bindings-data (make-fluid))
61
62(define lexical-binding (make-fluid))
63
64;;; Find the source properties of some parsed expression if there are
65;;; any associated with it.
66
67(define (location x)
68 (and (pair? x)
69 (let ((props (source-properties x)))
70 (and (not (null? props))
71 props))))
72
73;;; Values to use for Elisp's nil and t.
74
75(define (nil-value loc)
76 (make-const loc (@ (language elisp runtime) nil-value)))
77
78(define (t-value loc)
79 (make-const loc (@ (language elisp runtime) t-value)))
80
81;;; Modules that contain the value and function slot bindings.
82
83(define runtime '(language elisp runtime))
84
85(define value-slot (@ (language elisp runtime) value-slot-module))
86
87(define function-slot (@ (language elisp runtime) function-slot-module))
88
89;;; The backquoting works the same as quasiquotes in Scheme, but the
90;;; forms are named differently; to make easy adaptions, we define these
91;;; predicates checking for a symbol being the car of an
92;;; unquote/unquote-splicing/backquote form.
93
94(define (unquote? sym)
95 (and (symbol? sym) (eq? sym '#{,}#)))
96
97(define (unquote-splicing? sym)
98 (and (symbol? sym) (eq? sym '#{,@}#)))
99
100;;; Build a call to a primitive procedure nicely.
101
102(define (call-primitive loc sym . args)
103 (make-application loc (make-primitive-ref loc sym) args))
104
105;;; Error reporting routine for syntax/compilation problems or build
106;;; code for a runtime-error output.
107
108(define (report-error loc . args)
109 (apply error args))
110
111;;; Generate code to ensure a global symbol is there for further use of
112;;; a given symbol. In general during the compilation, those needed are
113;;; only tracked with the bindings data structure. Afterwards, however,
114;;; for all those needed symbols the globals are really generated with
115;;; this routine.
116
117(define (generate-ensure-global loc sym module)
118 (make-application loc
119 (make-module-ref loc runtime 'ensure-fluid! #t)
120 (list (make-const loc module)
121 (make-const loc sym))))
122
123(define (ensuring-globals loc bindings body)
124 (make-sequence
125 loc
126 `(,@(map-globals (fluid-ref bindings)
127 (lambda (mod sym)
128 (generate-ensure-global loc sym mod)))
129 ,body)))
130
131;;; Build a construct that establishes dynamic bindings for certain
132;;; variables. We may want to choose between binding with fluids and
133;;; with-fluids* and using just ordinary module symbols and
134;;; setting/reverting their values with a dynamic-wind.
135
136(define (let-dynamic loc syms module vals body)
137 (call-primitive
138 loc
139 'with-fluids*
140 (make-application loc
141 (make-primitive-ref loc 'list)
142 (map (lambda (sym)
143 (make-module-ref loc module sym #t))
144 syms))
145 (make-application loc (make-primitive-ref loc 'list) vals)
146 (make-lambda loc
147 '()
148 (make-lambda-case #f '() #f #f #f '() '() body #f))))
149
150;;; Handle access to a variable (reference/setting) correctly depending
151;;; on whether it is currently lexically or dynamically bound. lexical
152;;; access is done only for references to the value-slot module!
153
154(define (access-variable loc
155 sym
156 module
157 handle-global
158 handle-lexical
159 handle-dynamic)
160 (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
161 (cond
162 (lexical (handle-lexical lexical))
163 ((equal? module function-slot) (handle-global))
164 (else (handle-dynamic)))))
165
166;;; Generate code to reference a variable. For references in the
167;;; value-slot module, we may want to generate a lexical reference
168;;; instead if the variable has a lexical binding.
169
170(define (reference-variable loc sym module)
171 (access-variable
172 loc
173 sym
174 module
175 (lambda () (make-module-ref loc module sym #t))
176 (lambda (lexical) (make-lexical-ref loc lexical lexical))
177 (lambda ()
178 (mark-global! (fluid-ref bindings-data) sym module)
179 (call-primitive loc
180 'fluid-ref
181 (make-module-ref loc module sym #t)))))
182
183;;; Generate code to set a variable. Just as with reference-variable, in
184;;; case of a reference to value-slot, we want to generate a lexical set
185;;; when the variable has a lexical binding.
186
187(define (set-variable! loc sym module value)
188 (access-variable
189 loc
190 sym
191 module
192 (lambda ()
193 (make-application
194 loc
195 (make-module-ref loc runtime 'set-symbol-function! #t) ;++ fix
196 (list (make-const loc sym) value)))
197 (lambda (lexical) (make-lexical-set loc lexical lexical value))
198 (lambda ()
199 (mark-global! (fluid-ref bindings-data) sym module)
200 (call-primitive loc
201 'fluid-set!
202 (make-module-ref loc module sym #t)
203 value))))
204
205(define (bind-lexically? sym module decls)
206 (or (eq? module function-slot)
207 (let ((decl (assq-ref decls sym)))
208 (and (equal? module value-slot)
209 (or
210 (eq? decl 'lexical)
211 (and
212 (fluid-ref lexical-binding)
213 (not (global? (fluid-ref bindings-data) sym module))))))))
214
215(define (parse-let-binding loc binding)
216 (pmatch binding
217 ((unquote var)
218 (guard (symbol? var))
219 (cons var #nil))
220 ((,var)
221 (guard (symbol? var))
222 (cons var #nil))
223 ((,var ,val)
224 (guard (symbol? var))
225 (cons var val))
226 (else
227 (report-error loc "malformed variable binding" binding))))
228
229(define (parse-flet-binding loc binding)
230 (pmatch binding
231 ((,var ,args . ,body)
232 (guard (symbol? var))
233 (cons var `(function (lambda ,args ,@body))))
234 (else
235 (report-error loc "malformed function binding" binding))))
236
237(define (parse-declaration expr)
238 (pmatch expr
239 ((lexical . ,vars)
240 (map (cut cons <> 'lexical) vars))
241 (else
242 '())))
243
244(define (parse-body-1 body lambda?)
245 (let loop ((lst body)
246 (decls '())
247 (intspec #f)
248 (doc #f))
249 (pmatch lst
250 (((declare . ,x) . ,tail)
251 (loop tail (append-reverse x decls) intspec doc))
252 (((interactive . ,x) . ,tail)
253 (guard lambda? (not intspec))
254 (loop tail decls x doc))
255 ((,x . ,tail)
256 (guard lambda? (string? x) (not doc) (not (null? tail)))
257 (loop tail decls intspec x))
258 (else
259 (values (append-map parse-declaration decls)
260 intspec
261 doc
262 lst)))))
263
264(define (parse-lambda-body body)
265 (parse-body-1 body #t))
266
267(define (parse-body body)
268 (receive (decls intspec doc body) (parse-body-1 body #f)
269 (values decls body)))
270
271;;; Compile let and let* expressions. The code here is used both for
272;;; let/let* and flet, just with a different bindings module.
273
274;;; Let is done with a single call to let-dynamic binding them locally
275;;; to new values all "at once". If there is at least one variable to
276;;; bind lexically among the bindings, we first do a let for all of them
277;;; to evaluate all values before any bindings take place, and then call
278;;; let-dynamic for the variables to bind dynamically.
279
280(define (generate-let loc module bindings body)
281 (receive (decls forms) (parse-body body)
282 (receive (lexical dynamic)
283 (partition (compose (cut bind-lexically? <> module decls)
284 car)
285 bindings)
286 (for-each (lambda (sym)
287 (mark-global! (fluid-ref bindings-data)
288 sym
289 module))
290 (map car dynamic))
291 (let ((make-values (lambda (for)
292 (map (lambda (el) (compile-expr (cdr el)))
293 for)))
294 (make-body (lambda () (compile-expr `(progn ,@forms)))))
295 (if (null? lexical)
296 (let-dynamic loc (map car dynamic) module
297 (make-values dynamic) (make-body))
298 (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
299 (dynamic-syms (map (lambda (el) (gensym)) dynamic))
300 (all-syms (append lexical-syms dynamic-syms))
301 (vals (append (make-values lexical)
302 (make-values dynamic))))
303 (make-let loc
304 all-syms
305 all-syms
306 vals
307 (with-lexical-bindings
308 (fluid-ref bindings-data)
309 (map car lexical) lexical-syms
310 (lambda ()
311 (if (null? dynamic)
312 (make-body)
313 (let-dynamic loc
314 (map car dynamic)
315 module
316 (map
317 (lambda (sym)
318 (make-lexical-ref loc
319 sym
320 sym))
321 dynamic-syms)
322 (make-body))))))))))))
323
324;;; Let* is compiled to a cascaded set of "small lets" for each binding
325;;; in turn so that each one already sees the preceding bindings.
326
327(define (generate-let* loc module bindings body)
328 (receive (decls forms) (parse-body body)
329 (begin
330 (for-each (lambda (sym)
331 (if (not (bind-lexically? sym module decls))
332 (mark-global! (fluid-ref bindings-data)
333 sym
334 module)))
335 (map car bindings))
336 (let iterate ((tail bindings))
337 (if (null? tail)
338 (compile-expr `(progn ,@forms))
339 (let ((sym (caar tail))
340 (value (compile-expr (cdar tail))))
341 (if (bind-lexically? sym module decls)
342 (let ((target (gensym)))
343 (make-let loc
344 `(,target)
345 `(,target)
346 `(,value)
347 (with-lexical-bindings
348 (fluid-ref bindings-data)
349 `(,sym)
350 `(,target)
351 (lambda () (iterate (cdr tail))))))
352 (let-dynamic loc
353 `(,(caar tail))
354 module
355 `(,value)
356 (iterate (cdr tail))))))))))
357
358;;; Partition the argument list of a lambda expression into required,
359;;; optional and rest arguments.
360
361(define (parse-lambda-list lst)
362 (define (%match lst null optional rest symbol)
363 (pmatch lst
364 (() (null))
365 ((&optional . ,tail) (optional tail))
366 ((&rest . ,tail) (rest tail))
367 ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
368 (else (fail))))
369 (define (return rreq ropt rest)
370 (values #t (reverse rreq) (reverse ropt) rest))
371 (define (fail)
372 (values #f #f #f #f))
373 (define (parse-req lst rreq)
374 (%match lst
375 (lambda () (return rreq '() #f))
376 (lambda (tail) (parse-opt tail rreq '()))
377 (lambda (tail) (parse-rest tail rreq '()))
378 (lambda (arg tail) (parse-req tail (cons arg rreq)))))
379 (define (parse-opt lst rreq ropt)
380 (%match lst
381 (lambda () (return rreq ropt #f))
382 (lambda (tail) (fail))
383 (lambda (tail) (parse-rest tail rreq ropt))
384 (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
385 (define (parse-rest lst rreq ropt)
386 (%match lst
387 (lambda () (fail))
388 (lambda (tail) (fail))
389 (lambda (tail) (fail))
390 (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
391 (define (parse-post-rest lst rreq ropt rest)
392 (%match lst
393 (lambda () (return rreq ropt rest))
394 (lambda () (fail))
395 (lambda () (fail))
396 (lambda (arg tail) (fail))))
397 (parse-req lst '()))
398
399(define (make-simple-lambda loc meta req opt init rest vars body)
400 (make-lambda loc
401 meta
402 (make-lambda-case #f req opt rest #f init vars body #f)))
403
404(define (compile-lambda loc meta args body)
405 (receive (valid? req-ids opt-ids rest-id)
406 (parse-lambda-list args)
407 (if valid?
408 (let* ((all-ids (append req-ids
409 opt-ids
410 (or (and=> rest-id list) '())))
411 (all-vars (map (lambda (ignore) (gensym)) all-ids)))
412 (let*-values (((decls intspec doc forms)
413 (parse-lambda-body body))
414 ((lexical dynamic)
415 (partition
416 (compose (cut bind-lexically? <> value-slot decls)
417 car)
418 (map list all-ids all-vars)))
419 ((lexical-ids lexical-vars) (unzip2 lexical))
420 ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
421 (with-dynamic-bindings
422 (fluid-ref bindings-data)
423 dynamic-ids
424 (lambda ()
425 (with-lexical-bindings
426 (fluid-ref bindings-data)
427 lexical-ids
428 lexical-vars
429 (lambda ()
430 (let* ((tree-il (compile-expr `(progn ,@forms)))
431 (full-body
432 (if (null? dynamic)
433 tree-il
434 (let-dynamic loc
435 dynamic-ids
436 value-slot
437 (map (cut make-lexical-ref
438 loc
439 <>
440 <>)
441 dynamic-ids
442 dynamic-vars)
443 tree-il))))
444 (make-simple-lambda loc
445 meta
446 req-ids
447 opt-ids
448 (map (const (nil-value loc))
449 opt-ids)
450 rest-id
451 all-vars
452 full-body))))))))
453 (report-error "invalid function" `(lambda ,args ,@body)))))
454
455;;; Handle the common part of defconst and defvar, that is, checking for
456;;; a correct doc string and arguments as well as maybe in the future
457;;; handling the docstring somehow.
458
459(define (handle-var-def loc sym doc)
460 (cond
461 ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
462 ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
463 ((and (not (null? doc)) (not (string? (car doc))))
464 (report-error loc "expected string as third argument of defvar, got"
465 (car doc)))
466 ;; TODO: Handle doc string if present.
467 (else #t)))
468
469;;; Handle macro and special operator bindings.
470
471(define (find-operator name type)
472 (and
473 (symbol? name)
474 (module-defined? (resolve-interface function-slot) name)
475 (let ((op (module-ref (resolve-module function-slot) name)))
476 (if (and (pair? op) (eq? (car op) type))
477 (cdr op)
478 #f))))
479
480;;; See if a (backquoted) expression contains any unquotes.
481
482(define (contains-unquotes? expr)
483 (if (pair? expr)
484 (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
485 #t
486 (or (contains-unquotes? (car expr))
487 (contains-unquotes? (cdr expr))))
488 #f))
489
490;;; Process a backquoted expression by building up the needed
491;;; cons/append calls. For splicing, it is assumed that the expression
492;;; spliced in evaluates to a list. The emacs manual does not really
493;;; state either it has to or what to do if it does not, but Scheme
494;;; explicitly forbids it and this seems reasonable also for elisp.
495
496(define (unquote-cell? expr)
497 (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
498
499(define (unquote-splicing-cell? expr)
500 (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
501
502(define (process-backquote loc expr)
503 (if (contains-unquotes? expr)
504 (if (pair? expr)
505 (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
506 (compile-expr (cadr expr))
507 (let* ((head (car expr))
508 (processed-tail (process-backquote loc (cdr expr)))
509 (head-is-list-2 (and (list? head)
510 (= (length head) 2)))
511 (head-unquote (and head-is-list-2
512 (unquote? (car head))))
513 (head-unquote-splicing (and head-is-list-2
514 (unquote-splicing?
515 (car head)))))
516 (if head-unquote-splicing
517 (call-primitive loc
518 'append
519 (compile-expr (cadr head))
520 processed-tail)
521 (call-primitive loc 'cons
522 (if head-unquote
523 (compile-expr (cadr head))
524 (process-backquote loc head))
525 processed-tail))))
526 (report-error loc
527 "non-pair expression contains unquotes"
528 expr))
529 (make-const loc expr)))
530
531;;; Special operators
532
533(defspecial progn (loc args)
534 (make-sequence loc
535 (if (null? args)
536 (list (nil-value loc))
537 (map compile-expr args))))
538
539(defspecial eval-when-compile (loc args)
540 (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
541
542(defspecial if (loc args)
543 (pmatch args
544 ((,cond ,then . ,else)
545 (make-conditional
546 loc
547 (call-primitive loc 'not
548 (call-primitive loc 'nil? (compile-expr cond)))
549 (compile-expr then)
550 (compile-expr `(progn ,@else))))))
551
552(defspecial defconst (loc args)
553 (pmatch args
554 ((,sym ,value . ,doc)
555 (if (handle-var-def loc sym doc)
556 (make-sequence loc
557 (list (set-variable! loc
558 sym
559 value-slot
560 (compile-expr value))
561 (make-const loc sym)))))))
562
563(defspecial defvar (loc args)
564 (pmatch args
565 ((,sym) (make-const loc sym))
566 ((,sym ,value . ,doc)
567 (if (handle-var-def loc sym doc)
568 (make-sequence
569 loc
570 (list
571 (make-conditional
572 loc
573 (make-conditional
574 loc
575 (call-primitive
576 loc
577 'module-bound?
578 (call-primitive loc
579 'resolve-interface
580 (make-const loc value-slot))
581 (make-const loc sym))
582 (call-primitive loc
583 'fluid-bound?
584 (make-module-ref loc value-slot sym #t))
585 (make-const loc #f))
586 (make-void loc)
587 (set-variable! loc sym value-slot (compile-expr value)))
588 (make-const loc sym)))))))
589
590(defspecial setq (loc args)
591 (define (car* x) (if (null? x) '() (car x)))
592 (define (cdr* x) (if (null? x) '() (cdr x)))
593 (define (cadr* x) (car* (cdr* x)))
594 (define (cddr* x) (cdr* (cdr* x)))
595 (make-sequence
596 loc
597 (let loop ((args args) (last (nil-value loc)))
598 (if (null? args)
599 (list last)
600 (let ((sym (car args))
601 (val (compile-expr (cadr* args))))
602 (if (not (symbol? sym))
603 (report-error loc "expected symbol in setq")
604 (cons
605 (set-variable! loc sym value-slot val)
606 (loop (cddr* args)
607 (reference-variable loc sym value-slot)))))))))
608
609(defspecial let (loc args)
610 (pmatch args
611 ((,bindings . ,body)
612 (generate-let loc
613 value-slot
614 (map (cut parse-let-binding loc <>) bindings)
615 body))))
616
617(defspecial flet (loc args)
618 (pmatch args
619 ((,bindings . ,body)
620 (generate-let loc
621 function-slot
622 (map (cut parse-flet-binding loc <>) bindings)
623 body))))
624
625(defspecial labels (loc args)
626 (pmatch args
627 ((,bindings . ,body)
628 (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
629 (receive (decls forms) (parse-body body)
630 (let ((names (map car names+vals))
631 (vals (map cdr names+vals))
632 (gensyms (map (lambda (x) (gensym)) names+vals)))
633 (with-lexical-bindings
634 (fluid-ref bindings-data)
635 names
636 gensyms
637 (lambda ()
638 (make-letrec #f
639 loc
640 names
641 gensyms
642 (map compile-expr vals)
643 (compile-expr `(progn ,@forms)))))))))))
644
645(defspecial let* (loc args)
646 (pmatch args
647 ((,bindings . ,body)
648 (generate-let* loc
649 value-slot
650 (map (cut parse-let-binding loc <>) bindings)
651 body))))
652
653;;; guile-ref allows building TreeIL's module references from within
654;;; elisp as a way to access data within the Guile universe. The module
655;;; and symbol referenced are static values, just like (@ module symbol)
656;;; does!
657
658(defspecial guile-ref (loc args)
659 (pmatch args
660 ((,module ,sym) (guard (and (list? module) (symbol? sym)))
661 (make-module-ref loc module sym #t))))
662
663;;; guile-primitive allows to create primitive references, which are
664;;; still a little faster.
665
666(defspecial guile-primitive (loc args)
667 (pmatch args
668 ((,sym)
669 (make-primitive-ref loc sym))))
670
671(defspecial function (loc args)
672 (pmatch args
673 (((lambda ,args . ,body))
674 (compile-lambda loc '() args body))
675 ((,sym) (guard (symbol? sym))
676 (reference-variable loc sym function-slot))))
677
678(defspecial defmacro (loc args)
679 (pmatch args
680 ((,name ,args . ,body)
681 (if (not (symbol? name))
682 (report-error loc "expected symbol as macro name" name)
683 (let* ((tree-il
684 (make-sequence
685 loc
686 (list
687 (set-variable!
688 loc
689 name
690 function-slot
691 (make-application
692 loc
693 (make-module-ref loc '(guile) 'cons #t)
694 (list (make-const loc 'macro)
695 (compile-lambda loc
696 `((name . ,name))
697 args
698 body))))
699 (make-const loc name)))))
700 (compile (ensuring-globals loc bindings-data tree-il)
701 #:from 'tree-il
702 #:to 'value)
703 tree-il)))))
704
705(defspecial defun (loc args)
706 (pmatch args
707 ((,name ,args . ,body)
708 (if (not (symbol? name))
709 (report-error loc "expected symbol as function name" name)
710 (make-sequence loc
711 (list (set-variable! loc
712 name
713 function-slot
714 (compile-lambda loc
715 `((name . ,name))
716 args
717 body))
718 (make-const loc name)))))))
719
720(defspecial #{`}# (loc args)
721 (pmatch args
722 ((,val)
723 (process-backquote loc val))))
724
725(defspecial quote (loc args)
726 (pmatch args
727 ((,val)
728 (make-const loc val))))
729
730(defspecial %funcall (loc args)
731 (pmatch args
732 ((,function . ,arguments)
733 (make-application loc
734 (compile-expr function)
735 (map compile-expr arguments)))))
736
737(defspecial %set-lexical-binding-mode (loc args)
738 (pmatch args
739 ((,val)
740 (fluid-set! lexical-binding val)
741 (make-void loc))))
742
743;;; Compile a compound expression to Tree-IL.
744
745(define (compile-pair loc expr)
746 (let ((operator (car expr))
747 (arguments (cdr expr)))
748 (cond
749 ((find-operator operator 'special-operator)
750 => (lambda (special-operator-function)
751 (special-operator-function loc arguments)))
752 ((find-operator operator 'macro)
753 => (lambda (macro-function)
754 (compile-expr (apply macro-function arguments))))
755 (else
756 (compile-expr `(%funcall (function ,operator) ,@arguments))))))
757
758;;; Compile a symbol expression. This is a variable reference or maybe
759;;; some special value like nil.
760
761(define (compile-symbol loc sym)
762 (case sym
763 ((nil) (nil-value loc))
764 ((t) (t-value loc))
765 (else (reference-variable loc sym value-slot))))
766
767;;; Compile a single expression to TreeIL.
768
769(define (compile-expr expr)
770 (let ((loc (location expr)))
771 (cond
772 ((symbol? expr)
773 (compile-symbol loc expr))
774 ((pair? expr)
775 (compile-pair loc expr))
776 (else (make-const loc expr)))))
777
778;;; Process the compiler options.
779;;; FIXME: Why is '(()) passed as options by the REPL?
780
781(define (valid-symbol-list-arg? value)
782 (or (eq? value 'all)
783 (and (list? value) (and-map symbol? value))))
784
785(define (process-options! opt)
786 (if (and (not (null? opt))
787 (not (equal? opt '(()))))
788 (if (null? (cdr opt))
789 (report-error #f "Invalid compiler options" opt)
790 (let ((key (car opt))
791 (value (cadr opt)))
792 (case key
793 ((#:warnings) ; ignore
794 #f)
795 (else (report-error #f
796 "Invalid compiler option"
797 key)))))))
798
799;;; Entry point for compilation to TreeIL. This creates the bindings
800;;; data structure, and after compiling the main expression we need to
801;;; make sure all globals for symbols used during the compilation are
802;;; created using the generate-ensure-global function.
803
804(define (compile-tree-il expr env opts)
805 (values
806 (with-fluids ((bindings-data (make-bindings)))
807 (process-options! opts)
808 (let ((compiled (compile-expr expr)))
809 (ensuring-globals (location expr) bindings-data compiled)))
810 env
811 env))