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