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

   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 ;;; Let is done with a single call to let-dynamic binding them locally
 272 ;;; to new values all "at once".  If there is at least one variable to
 273 ;;; bind lexically among the bindings, we first do a let for all of them
 274 ;;; to evaluate all values before any bindings take place, and then call
 275 ;;; let-dynamic for the variables to bind dynamically.
 276
 277 (define (generate-let loc module bindings body)
 278   (receive (decls forms) (parse-body body)
 279     (receive (lexical dynamic)
 280              (partition (compose (cut bind-lexically? <> module decls)
 281                                  car)
 282                         bindings)
 283       (for-each (lambda (sym)
 284                   (mark-global! (fluid-ref bindings-data)
 285                                 sym
 286                                 module))
 287                 (map car dynamic))
 288       (let ((make-values (lambda (for)
 289                            (map (lambda (el) (compile-expr (cdr el)))
 290                                 for)))
 291             (make-body (lambda () (compile-expr `(progn ,@forms)))))
 292         (if (null? lexical)
 293             (let-dynamic loc (map car dynamic) module
 294                          (make-values dynamic) (make-body))
 295             (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
 296                    (dynamic-syms (map (lambda (el) (gensym)) dynamic))
 297                    (all-syms (append lexical-syms dynamic-syms))
 298                    (vals (append (make-values lexical)
 299                                  (make-values dynamic))))
 300               (make-let loc
 301                         all-syms
 302                         all-syms
 303                         vals
 304                         (with-lexical-bindings
 305                          (fluid-ref bindings-data)
 306                          (map car lexical) lexical-syms
 307                          (lambda ()
 308                            (if (null? dynamic)
 309                                (make-body)
 310                                (let-dynamic loc
 311                                             (map car dynamic)
 312                                             module
 313                                             (map
 314                                              (lambda (sym)
 315                                                (make-lexical-ref loc
 316                                                                  sym
 317                                                                  sym))
 318                                              dynamic-syms)
 319                                             (make-body))))))))))))
 320
 321 ;;; Let* is compiled to a cascaded set of "small lets" for each binding
 322 ;;; in turn so that each one already sees the preceding bindings.
 323
 324 (define (generate-let* loc module bindings body)
 325   (receive (decls forms) (parse-body body)
 326     (begin
 327       (for-each (lambda (sym)
 328                   (if (not (bind-lexically? sym module decls))
 329                       (mark-global! (fluid-ref bindings-data)
 330                                     sym
 331                                     module)))
 332                 (map car bindings))
 333       (let iterate ((tail bindings))
 334         (if (null? tail)
 335             (compile-expr `(progn ,@forms))
 336             (let ((sym (caar tail))
 337                   (value (compile-expr (cdar tail))))
 338               (if (bind-lexically? sym module decls)
 339                   (let ((target (gensym)))
 340                     (make-let loc
 341                               `(,target)
 342                               `(,target)
 343                               `(,value)
 344                               (with-lexical-bindings
 345                                (fluid-ref bindings-data)
 346                                `(,sym)
 347                                `(,target)
 348                                (lambda () (iterate (cdr tail))))))
 349                   (let-dynamic loc
 350                                `(,(caar tail))
 351                                module
 352                                `(,value)
 353                                (iterate (cdr tail))))))))))
 354
 355 ;;; Partition the argument list of a lambda expression into required,
 356 ;;; optional and rest arguments.
 357
 358 (define (parse-lambda-list lst)
 359   (define (%match lst null optional rest symbol)
 360     (pmatch lst
 361       (() (null))
 362       ((&optional . ,tail) (optional tail))
 363       ((&rest . ,tail) (rest tail))
 364       ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
 365       (else (fail))))
 366   (define (return rreq ropt rest)
 367     (values #t (reverse rreq) (reverse ropt) rest))
 368   (define (fail)
 369     (values #f #f #f #f))
 370   (define (parse-req lst rreq)
 371     (%match lst
 372             (lambda () (return rreq '() #f))
 373             (lambda (tail) (parse-opt tail rreq '()))
 374             (lambda (tail) (parse-rest tail rreq '()))
 375             (lambda (arg tail) (parse-req tail (cons arg rreq)))))
 376   (define (parse-opt lst rreq ropt)
 377     (%match lst
 378             (lambda () (return rreq ropt #f))
 379             (lambda (tail) (fail))
 380             (lambda (tail) (parse-rest tail rreq ropt))
 381             (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
 382   (define (parse-rest lst rreq ropt)
 383     (%match lst
 384             (lambda () (fail))
 385             (lambda (tail) (fail))
 386             (lambda (tail) (fail))
 387             (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
 388   (define (parse-post-rest lst rreq ropt rest)
 389     (%match lst
 390             (lambda () (return rreq ropt rest))
 391             (lambda () (fail))
 392             (lambda () (fail))
 393             (lambda (arg tail) (fail))))
 394   (parse-req lst '()))
 395
 396 (define (make-simple-lambda loc meta req opt init rest vars body)
 397   (make-lambda loc
 398                meta
 399                (make-lambda-case #f req opt rest #f init vars body #f)))
 400
 401 (define (compile-lambda loc meta args body)
 402   (receive (valid? req-ids opt-ids rest-id)
 403            (parse-lambda-list args)
 404     (if valid?
 405         (let* ((all-ids (append req-ids
 406                                 opt-ids
 407                                 (or (and=> rest-id list) '())))
 408                (all-vars (map (lambda (ignore) (gensym)) all-ids)))
 409           (let*-values (((decls intspec doc forms)
 410                          (parse-lambda-body body))
 411                         ((lexical dynamic)
 412                          (partition
 413                           (compose (cut bind-lexically? <> value-slot decls)
 414                                    car)
 415                           (map list all-ids all-vars)))
 416                         ((lexical-ids lexical-vars) (unzip2 lexical))
 417                         ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
 418             (with-dynamic-bindings
 419              (fluid-ref bindings-data)
 420              dynamic-ids
 421              (lambda ()
 422                (with-lexical-bindings
 423                 (fluid-ref bindings-data)
 424                 lexical-ids
 425                 lexical-vars
 426                 (lambda ()
 427                   (let* ((tree-il (compile-expr `(progn ,@forms)))
 428                          (full-body
 429                           (if (null? dynamic)
 430                               tree-il
 431                               (let-dynamic loc
 432                                            dynamic-ids
 433                                            value-slot
 434                                            (map (cut make-lexical-ref
 435                                                      loc
 436                                                      <>
 437                                                      <>)
 438                                                 dynamic-ids
 439                                                 dynamic-vars)
 440                                            tree-il))))
 441                     (make-simple-lambda loc
 442                                         meta
 443                                         req-ids
 444                                         opt-ids
 445                                         (map (const (nil-value loc))
 446                                              opt-ids)
 447                                         rest-id
 448                                         all-vars
 449                                         full-body))))))))
 450         (report-error "invalid function" `(lambda ,args ,@body)))))
 451
 452 ;;; Handle the common part of defconst and defvar, that is, checking for
 453 ;;; a correct doc string and arguments as well as maybe in the future
 454 ;;; handling the docstring somehow.
 455
 456 (define (handle-var-def loc sym doc)
 457   (cond
 458    ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
 459    ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
 460    ((and (not (null? doc)) (not (string? (car doc))))
 461     (report-error loc "expected string as third argument of defvar, got"
 462                   (car doc)))
 463    ;; TODO: Handle doc string if present.
 464    (else #t)))
 465
 466 ;;; Handle macro and special operator bindings.
 467
 468 (define (find-operator name type)
 469   (and
 470    (symbol? name)
 471    (module-defined? (resolve-interface function-slot) name)
 472    (let ((op (module-ref (resolve-module function-slot) name)))
 473      (if (and (pair? op) (eq? (car op) type))
 474          (cdr op)
 475          #f))))
 476
 477 ;;; See if a (backquoted) expression contains any unquotes.
 478
 479 (define (contains-unquotes? expr)
 480   (if (pair? expr)
 481       (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
 482           #t
 483           (or (contains-unquotes? (car expr))
 484               (contains-unquotes? (cdr expr))))
 485       #f))
 486
 487 ;;; Process a backquoted expression by building up the needed
 488 ;;; cons/append calls.  For splicing, it is assumed that the expression
 489 ;;; spliced in evaluates to a list.  The emacs manual does not really
 490 ;;; state either it has to or what to do if it does not, but Scheme
 491 ;;; explicitly forbids it and this seems reasonable also for elisp.
 492
 493 (define (unquote-cell? expr)
 494   (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
 495
 496 (define (unquote-splicing-cell? expr)
 497   (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
 498
 499 (define (process-backquote loc expr)
 500   (if (contains-unquotes? expr)
 501       (if (pair? expr)
 502           (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
 503               (compile-expr (cadr expr))
 504               (let* ((head (car expr))
 505                      (processed-tail (process-backquote loc (cdr expr)))
 506                      (head-is-list-2 (and (list? head)
 507                                           (= (length head) 2)))
 508                      (head-unquote (and head-is-list-2
 509                                         (unquote? (car head))))
 510                      (head-unquote-splicing (and head-is-list-2
 511                                                  (unquote-splicing?
 512                                                   (car head)))))
 513                 (if head-unquote-splicing
 514                     (call-primitive loc
 515                                     'append
 516                                     (compile-expr (cadr head))
 517                                     processed-tail)
 518                     (call-primitive loc 'cons
 519                                     (if head-unquote
 520                                         (compile-expr (cadr head))
 521                                         (process-backquote loc head))
 522                                     processed-tail))))
 523           (report-error loc
 524                         "non-pair expression contains unquotes"
 525                         expr))
 526       (make-const loc expr)))
 527
 528 ;;; Special operators
 529
 530 (defspecial progn (loc args)
 531   (make-sequence loc
 532                  (if (null? args)
 533                      (list (nil-value loc))
 534                      (map compile-expr args))))
 535
 536 (defspecial eval-when-compile (loc args)
 537   (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
 538
 539 (defspecial if (loc args)
 540   (pmatch args
 541     ((,cond ,then . ,else)
 542      (make-conditional
 543       loc
 544       (call-primitive loc 'not
 545        (call-primitive loc 'nil? (compile-expr cond)))
 546       (compile-expr then)
 547       (compile-expr `(progn ,@else))))))
 548
 549 (defspecial defconst (loc args)
 550   (pmatch args
 551     ((,sym ,value . ,doc)
 552      (if (handle-var-def loc sym doc)
 553          (make-sequence loc
 554                         (list (set-variable! loc
 555                                              sym
 556                                              value-slot
 557                                              (compile-expr value))
 558                               (make-const loc sym)))))))
 559
 560 (defspecial defvar (loc args)
 561   (pmatch args
 562     ((,sym) (make-const loc sym))
 563     ((,sym ,value . ,doc)
 564      (if (handle-var-def loc sym doc)
 565          (make-sequence
 566           loc
 567           (list
 568            (make-conditional
 569             loc
 570             (make-conditional
 571              loc
 572              (call-primitive
 573               loc
 574               'module-bound?
 575               (call-primitive loc
 576                               'resolve-interface
 577                               (make-const loc value-slot))
 578               (make-const loc sym))
 579              (call-primitive loc
 580                              'fluid-bound?
 581                              (make-module-ref loc value-slot sym #t))
 582              (make-const loc #f))
 583             (make-void loc)
 584             (set-variable! loc sym value-slot (compile-expr value)))
 585            (make-const loc sym)))))))
 586
 587 (defspecial setq (loc args)
 588   (define (car* x) (if (null? x) '() (car x)))
 589   (define (cdr* x) (if (null? x) '() (cdr x)))
 590   (define (cadr* x) (car* (cdr* x)))
 591   (define (cddr* x) (cdr* (cdr* x)))
 592   (make-sequence
 593    loc
 594    (let loop ((args args) (last (nil-value loc)))
 595      (if (null? args)
 596          (list last)
 597          (let ((sym (car args))
 598                (val (compile-expr (cadr* args))))
 599            (if (not (symbol? sym))
 600                (report-error loc "expected symbol in setq")
 601                (cons
 602                 (set-variable! loc sym value-slot val)
 603                 (loop (cddr* args)
 604                       (reference-variable loc sym value-slot)))))))))
 605
 606 (defspecial let (loc args)
 607   (pmatch args
 608     ((,bindings . ,body)
 609      (generate-let loc
 610                    value-slot
 611                    (map (cut parse-let-binding loc <>) bindings)
 612                    body))))
 613
 614 (defspecial flet (loc args)
 615   (pmatch args
 616     ((,bindings . ,body)
 617      (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
 618        (receive (decls forms) (parse-body body)
 619          (let ((names (map car names+vals))
 620                (vals (map cdr names+vals))
 621                (gensyms (map (lambda (x) (gensym)) names+vals)))
 622            (with-lexical-bindings
 623             (fluid-ref bindings-data)
 624             names
 625             gensyms
 626             (lambda ()
 627               (make-let loc
 628                         names
 629                         gensyms
 630                         (map compile-expr vals)
 631                         (compile-expr `(progn ,@forms)))))))))))
 632
 633 (defspecial labels (loc args)
 634   (pmatch args
 635     ((,bindings . ,body)
 636      (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
 637        (receive (decls forms) (parse-body body)
 638          (let ((names (map car names+vals))
 639                (vals (map cdr names+vals))
 640                (gensyms (map (lambda (x) (gensym)) names+vals)))
 641            (with-lexical-bindings
 642             (fluid-ref bindings-data)
 643             names
 644             gensyms
 645             (lambda ()
 646               (make-letrec #f
 647                            loc
 648                            names
 649                            gensyms
 650                            (map compile-expr vals)
 651                            (compile-expr `(progn ,@forms)))))))))))
 652
 653 (defspecial let* (loc args)
 654   (pmatch args
 655     ((,bindings . ,body)
 656      (generate-let* loc
 657                     value-slot
 658                     (map (cut parse-let-binding loc <>) bindings)
 659                     body))))
 660
 661 ;;; guile-ref allows building TreeIL's module references from within
 662 ;;; elisp as a way to access data within the Guile universe.  The module
 663 ;;; and symbol referenced are static values, just like (@ module symbol)
 664 ;;; does!
 665
 666 (defspecial guile-ref (loc args)
 667   (pmatch args
 668     ((,module ,sym) (guard (and (list? module) (symbol? sym)))
 669      (make-module-ref loc module sym #t))))
 670
 671 ;;; guile-primitive allows to create primitive references, which are
 672 ;;; still a little faster.
 673
 674 (defspecial guile-primitive (loc args)
 675   (pmatch args
 676     ((,sym)
 677      (make-primitive-ref loc sym))))
 678
 679 (defspecial function (loc args)
 680   (pmatch args
 681     (((lambda ,args . ,body))
 682      (compile-lambda loc '() args body))
 683     ((,sym) (guard (symbol? sym))
 684      (reference-variable loc sym function-slot))))
 685
 686 (defspecial defmacro (loc args)
 687   (pmatch args
 688     ((,name ,args . ,body)
 689      (if (not (symbol? name))
 690          (report-error loc "expected symbol as macro name" name)
 691          (let* ((tree-il
 692                  (make-sequence
 693                   loc
 694                   (list
 695                    (set-variable!
 696                     loc
 697                     name
 698                     function-slot
 699                     (make-application
 700                      loc
 701                      (make-module-ref loc '(guile) 'cons #t)
 702                      (list (make-const loc 'macro)
 703                            (compile-lambda loc
 704                                            `((name . ,name))
 705                                            args
 706                                            body))))
 707                    (make-const loc name)))))
 708            (compile (ensuring-globals loc bindings-data tree-il)
 709                     #:from 'tree-il
 710                     #:to 'value)
 711            tree-il)))))
 712
 713 (defspecial defun (loc args)
 714   (pmatch args
 715     ((,name ,args . ,body)
 716      (if (not (symbol? name))
 717          (report-error loc "expected symbol as function name" name)
 718          (make-sequence loc
 719                         (list (set-variable! loc
 720                                              name
 721                                              function-slot
 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-application 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 value-slot))))
 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)             ; ignore
 802                #f)
 803               (else (report-error #f
 804                                   "Invalid compiler option"
 805                                   key)))))))
 806
 807 ;;; Entry point for compilation to TreeIL.  This creates the bindings
 808 ;;; data structure, and after compiling the main expression we need to
 809 ;;; make sure all globals for symbols used during the compilation are
 810 ;;; created using the generate-ensure-global function.
 811
 812 (define (compile-tree-il expr env opts)
 813   (values
 814    (with-fluids ((bindings-data (make-bindings)))
 815      (process-options! opts)
 816      (let ((compiled (compile-expr expr)))
 817        (ensuring-globals (location expr) bindings-data compiled)))
 818    env
 819    env))