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