module/language/elisp/compile-tree-il.scm

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