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

   1 ;;; Guile Emacs Lisp
   2
   3 ;; Copyright (C) 2009, 2010, 2011 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-if
  35             compile-defconst
  36             compile-defvar
  37             compile-setq
  38             compile-let
  39             compile-lexical-let
  40             compile-flet
  41             compile-let*
  42             compile-lexical-let*
  43             compile-flet*
  44             compile-without-void-checks
  45             compile-with-always-lexical
  46             compile-guile-ref
  47             compile-guile-primitive
  48             compile-while
  49             compile-function
  50             compile-defmacro
  51             compile-defun
  52             #{compile-`}#
  53             compile-quote))
  54
  55 ;;; Certain common parameters (like the bindings data structure or
  56 ;;; compiler options) are not always passed around but accessed using
  57 ;;; fluids to simulate dynamic binding (hey, this is about elisp).
  58
  59 ;;; The bindings data structure to keep track of symbol binding related
  60 ;;; data.
  61
  62 (define bindings-data (make-fluid))
  63
  64 ;;; Store for which symbols (or all/none) void checks are disabled.
  65
  66 (define disable-void-check (make-fluid))
  67
  68 ;;; Store which symbols (or all/none) should always be bound lexically,
  69 ;;; even with ordinary let and as lambda arguments.
  70
  71 (define always-lexical (make-fluid))
  72
  73 ;;; Find the source properties of some parsed expression if there are
  74 ;;; any associated with it.
  75
  76 (define (location x)
  77   (and (pair? x)
  78        (let ((props (source-properties x)))
  79          (and (not (null? props))
  80               props))))
  81
  82 ;;; Values to use for Elisp's nil and t.
  83
  84 (define (nil-value loc)
  85   (make-const loc (@ (language elisp runtime) nil-value)))
  86
  87 (define (t-value loc)
  88   (make-const loc (@ (language elisp runtime) t-value)))
  89
  90 ;;; Modules that contain the value and function slot bindings.
  91
  92 (define runtime '(language elisp runtime))
  93
  94 (define value-slot (@ (language elisp runtime) value-slot-module))
  95
  96 (define function-slot (@ (language elisp runtime) function-slot-module))
  97
  98 ;;; The backquoting works the same as quasiquotes in Scheme, but the
  99 ;;; forms are named differently; to make easy adaptions, we define these
 100 ;;; predicates checking for a symbol being the car of an
 101 ;;; unquote/unquote-splicing/backquote form.
 102
 103 (define (unquote? sym)
 104   (and (symbol? sym) (eq? sym '#{,}#)))
 105
 106 (define (unquote-splicing? sym)
 107   (and (symbol? sym) (eq? sym '#{,@}#)))
 108
 109 ;;; Build a call to a primitive procedure nicely.
 110
 111 (define (call-primitive loc sym . args)
 112   (make-primcall loc sym args))
 113
 114 ;;; Error reporting routine for syntax/compilation problems or build
 115 ;;; code for a runtime-error output.
 116
 117 (define (report-error loc . args)
 118   (apply error args))
 119
 120 (define (runtime-error loc msg . args)
 121   (make-primcall loc 'error
 122                  (cons (make-const loc msg) args)))
 123
 124 ;;; Generate code to ensure a global symbol is there for further use of
 125 ;;; a given symbol.  In general during the compilation, those needed are
 126 ;;; only tracked with the bindings data structure.  Afterwards, however,
 127 ;;; for all those needed symbols the globals are really generated with
 128 ;;; this routine.
 129
 130 (define (generate-ensure-global loc sym module)
 131   (make-call loc
 132              (make-module-ref loc runtime 'ensure-fluid! #t)
 133              (list (make-const loc module)
 134                    (make-const loc sym))))
 135
 136 (define (ensuring-globals loc bindings body)
 137   (list->seq
 138    loc
 139    `(,@(map-globals-needed (fluid-ref bindings)
 140                            (lambda (mod sym)
 141                              (generate-ensure-global loc sym mod)))
 142      ,body)))
 143
 144 ;;; Build a construct that establishes dynamic bindings for certain
 145 ;;; variables.  We may want to choose between binding with fluids and
 146 ;;; with-fluids* and using just ordinary module symbols and
 147 ;;; setting/reverting their values with a dynamic-wind.
 148
 149 (define (let-dynamic loc syms module vals body)
 150   (call-primitive
 151    loc
 152    'with-fluids*
 153    (make-primcall loc 'list
 154                   (map (lambda (sym)
 155                          (make-module-ref loc module sym #t))
 156                        syms))
 157    (make-primcall loc 'list vals)
 158    (make-lambda loc
 159                 '()
 160                 (make-lambda-case #f '() #f #f #f '() '() body #f))))
 161
 162 ;;; Handle access to a variable (reference/setting) correctly depending
 163 ;;; on whether it is currently lexically or dynamically bound.  lexical
 164 ;;; access is done only for references to the value-slot module!
 165
 166 (define (access-variable loc
 167                          sym
 168                          module
 169                          handle-global
 170                          handle-lexical
 171                          handle-dynamic)
 172   (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
 173     (cond
 174      (lexical (handle-lexical lexical))
 175      ((equal? module function-slot) (handle-global))
 176      (else (handle-dynamic)))))
 177
 178 ;;; Generate code to reference a variable.  For references in the
 179 ;;; value-slot module, we may want to generate a lexical reference
 180 ;;; instead if the variable has a lexical binding.
 181
 182 (define (reference-variable loc sym module)
 183   (access-variable
 184    loc
 185    sym
 186    module
 187    (lambda () (make-module-ref loc module sym #t))
 188    (lambda (lexical) (make-lexical-ref loc lexical lexical))
 189    (lambda ()
 190      (mark-global-needed! (fluid-ref bindings-data) sym module)
 191      (call-primitive loc
 192                      'fluid-ref
 193                      (make-module-ref loc module sym #t)))))
 194
 195 ;;; Generate code to set a variable.  Just as with reference-variable, in
 196 ;;; case of a reference to value-slot, we want to generate a lexical set
 197 ;;; when the variable has a lexical binding.
 198
 199 (define (set-variable! loc sym module value)
 200   (access-variable
 201    loc
 202    sym
 203    module
 204    (lambda ()
 205      (make-call
 206       loc
 207       (make-module-ref loc runtime 'set-variable! #t)
 208       (list (make-const loc module) (make-const loc sym) value)))
 209    (lambda (lexical) (make-lexical-set loc lexical lexical value))
 210    (lambda ()
 211      (mark-global-needed! (fluid-ref bindings-data) sym module)
 212      (call-primitive loc
 213                      'fluid-set!
 214                      (make-module-ref loc module sym #t)
 215                      value))))
 216
 217 ;;; Process the bindings part of a let or let* expression; that is,
 218 ;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
 219 ;;; . val2) ...).
 220
 221 (define (process-let-bindings loc bindings)
 222   (map
 223    (lambda (b)
 224      (if (symbol? b)
 225          (cons b 'nil)
 226          (if (or (not (list? b))
 227                  (not (= (length b) 2)))
 228              (report-error
 229               loc
 230               "expected symbol or list of 2 elements in let")
 231              (if (not (symbol? (car b)))
 232                  (report-error loc "expected symbol in let")
 233                  (cons (car b) (cadr b))))))
 234    bindings))
 235
 236 ;;; Split the let bindings into a list to be done lexically and one
 237 ;;; dynamically.  A symbol will be bound lexically if and only if: We're
 238 ;;; processing a lexical-let (i.e. module is 'lexical), OR we're
 239 ;;; processing a value-slot binding AND the symbol is already lexically
 240 ;;; bound or is always lexical, OR we're processing a function-slot
 241 ;;; binding.
 242
 243 (define (bind-lexically? sym module)
 244   (or (eq? module 'lexical)
 245       (eq? module function-slot)
 246       (and (equal? module value-slot)
 247            (let ((always (fluid-ref always-lexical)))
 248              (or (eq? always 'all)
 249                  (memq sym always)
 250                  (get-lexical-binding (fluid-ref bindings-data) sym))))))
 251
 252 (define (split-let-bindings bindings module)
 253   (let iterate ((tail bindings)
 254                 (lexical '())
 255                 (dynamic '()))
 256     (if (null? tail)
 257         (values (reverse lexical) (reverse dynamic))
 258         (if (bind-lexically? (caar tail) module)
 259             (iterate (cdr tail) (cons (car tail) lexical) dynamic)
 260             (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
 261
 262 ;;; Compile let and let* expressions.  The code here is used both for
 263 ;;; let/let* and flet/flet*, just with a different bindings module.
 264 ;;;
 265 ;;; A special module value 'lexical means that we're doing a lexical-let
 266 ;;; instead and the bindings should not be saved to globals at all but
 267 ;;; be done with the lexical framework instead.
 268
 269 ;;; Let is done with a single call to let-dynamic binding them locally
 270 ;;; to new values all "at once".  If there is at least one variable to
 271 ;;; bind lexically among the bindings, we first do a let for all of them
 272 ;;; to evaluate all values before any bindings take place, and then call
 273 ;;; let-dynamic for the variables to bind dynamically.
 274
 275 (define (generate-let loc module bindings body)
 276   (let ((bind (process-let-bindings loc bindings)))
 277     (call-with-values
 278         (lambda () (split-let-bindings bind module))
 279       (lambda (lexical dynamic)
 280         (for-each (lambda (sym)
 281                     (mark-global-needed! (fluid-ref bindings-data)
 282                                          sym
 283                                          module))
 284                   (map car dynamic))
 285         (let ((make-values (lambda (for)
 286                              (map (lambda (el) (compile-expr (cdr el)))
 287                                   for)))
 288               (make-body (lambda ()
 289                            (list->seq loc (map compile-expr body)))))
 290           (if (null? lexical)
 291               (let-dynamic loc (map car dynamic) module
 292                            (make-values dynamic) (make-body))
 293               (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
 294                      (dynamic-syms (map (lambda (el) (gensym)) dynamic))
 295                      (all-syms (append lexical-syms dynamic-syms))
 296                      (vals (append (make-values lexical)
 297                                    (make-values dynamic))))
 298                 (make-let loc
 299                           all-syms
 300                           all-syms
 301                           vals
 302                           (with-lexical-bindings
 303                            (fluid-ref bindings-data)
 304                            (map car lexical) lexical-syms
 305                            (lambda ()
 306                              (if (null? dynamic)
 307                                  (make-body)
 308                                  (let-dynamic loc
 309                                               (map car dynamic)
 310                                               module
 311                                               (map
 312                                                (lambda (sym)
 313                                                  (make-lexical-ref loc
 314                                                                    sym
 315                                                                    sym))
 316                                                dynamic-syms)
 317                                               (make-body)))))))))))))
 318
 319 ;;; Let* is compiled to a cascaded set of "small lets" for each binding
 320 ;;; in turn so that each one already sees the preceding bindings.
 321
 322 (define (generate-let* loc module bindings body)
 323   (let ((bind (process-let-bindings loc bindings)))
 324     (begin
 325       (for-each (lambda (sym)
 326                   (if (not (bind-lexically? sym module))
 327                       (mark-global-needed! (fluid-ref bindings-data)
 328                                            sym
 329                                            module)))
 330                 (map car bind))
 331       (let iterate ((tail bind))
 332         (if (null? tail)
 333             (list->seq loc (map compile-expr body))
 334             (let ((sym (caar tail))
 335                   (value (compile-expr (cdar tail))))
 336               (if (bind-lexically? sym module)
 337                   (let ((target (gensym)))
 338                     (make-let loc
 339                               `(,target)
 340                               `(,target)
 341                               `(,value)
 342                               (with-lexical-bindings
 343                                (fluid-ref bindings-data)
 344                                `(,sym)
 345                                `(,target)
 346                                (lambda () (iterate (cdr tail))))))
 347                   (let-dynamic loc
 348                                `(,(caar tail))
 349                                module
 350                                `(,value)
 351                                (iterate (cdr tail))))))))))
 352
 353 ;;; Split the argument list of a lambda expression into required,
 354 ;;; optional and rest arguments and also check it is actually valid.
 355 ;;; Additionally, we create a list of all "local variables" (that is,
 356 ;;; required, optional and rest arguments together) and also this one
 357 ;;; split into those to be bound lexically and dynamically.  Returned is
 358 ;;; as multiple values: required optional rest lexical dynamic
 359
 360 (define (bind-arg-lexical? arg)
 361   (let ((always (fluid-ref always-lexical)))
 362     (or (eq? always 'all)
 363         (memq arg always))))
 364
 365 (define (split-lambda-arguments loc args)
 366   (let iterate ((tail args)
 367                 (mode 'required)
 368                 (required '())
 369                 (optional '())
 370                 (lexical '())
 371                 (dynamic '()))
 372     (cond
 373      ((null? tail)
 374       (let ((final-required (reverse required))
 375             (final-optional (reverse optional))
 376             (final-lexical (reverse lexical))
 377             (final-dynamic (reverse dynamic)))
 378         (values final-required
 379                 final-optional
 380                 #f
 381                 final-lexical
 382                 final-dynamic)))
 383      ((and (eq? mode 'required)
 384            (eq? (car tail) '&optional))
 385       (iterate (cdr tail) 'optional required optional lexical dynamic))
 386      ((eq? (car tail) '&rest)
 387       (if (or (null? (cdr tail))
 388               (not (null? (cddr tail))))
 389           (report-error loc "expected exactly one symbol after &rest")
 390           (let* ((rest (cadr tail))
 391                  (rest-lexical (bind-arg-lexical? rest))
 392                  (final-required (reverse required))
 393                  (final-optional (reverse optional))
 394                  (final-lexical (reverse (if rest-lexical
 395                                              (cons rest lexical)
 396                                              lexical)))
 397                  (final-dynamic (reverse (if rest-lexical
 398                                              dynamic
 399                                              (cons rest dynamic)))))
 400             (values final-required
 401                     final-optional
 402                     rest
 403                     final-lexical
 404                     final-dynamic))))
 405      (else
 406       (if (not (symbol? (car tail)))
 407           (report-error loc
 408                         "expected symbol in argument list, got"
 409                         (car tail))
 410           (let* ((arg (car tail))
 411                  (bind-lexical (bind-arg-lexical? arg))
 412                  (new-lexical (if bind-lexical
 413                                   (cons arg lexical)
 414                                   lexical))
 415                  (new-dynamic (if bind-lexical
 416                                   dynamic
 417                                   (cons arg dynamic))))
 418             (case mode
 419               ((required) (iterate (cdr tail) mode
 420                                    (cons arg required) optional
 421                                    new-lexical new-dynamic))
 422               ((optional) (iterate (cdr tail) mode
 423                                    required (cons arg optional)
 424                                    new-lexical new-dynamic))
 425               (else
 426                (error "invalid mode in split-lambda-arguments"
 427                       mode)))))))))
 428
 429 ;;; Compile a lambda expression.  One thing we have to be aware of is
 430 ;;; that lambda arguments are usually dynamically bound, even when a
 431 ;;; lexical binding is intact for a symbol.  For symbols that are marked
 432 ;;; as 'always lexical,' however, we lexically bind here as well, and
 433 ;;; thus we get them out of the let-dynamic call and register a lexical
 434 ;;; binding for them (the lexical target variable is already there,
 435 ;;; namely the real lambda argument from TreeIL).
 436
 437 (define (compile-lambda loc args body)
 438   (if (not (list? args))
 439       (report-error loc "expected list for argument-list" args))
 440   (if (null? body)
 441       (report-error loc "function body must not be empty"))
 442   (receive (required optional rest lexical dynamic)
 443            (split-lambda-arguments loc args)
 444     (define (process-args args)
 445       (define (find-pairs pairs filter)
 446         (lset-intersection (lambda (name+sym x)
 447                              (eq? (car name+sym) x))
 448                            pairs
 449                            filter))
 450       (let* ((syms (map (lambda (x) (gensym)) args))
 451              (pairs (map cons args syms))
 452              (lexical-pairs (find-pairs pairs lexical))
 453              (dynamic-pairs (find-pairs pairs dynamic)))
 454         (values syms pairs lexical-pairs dynamic-pairs)))
 455     (let*-values (((required-syms
 456                     required-pairs
 457                     required-lex-pairs
 458                     required-dyn-pairs)
 459                    (process-args required))
 460                   ((optional-syms
 461                     optional-pairs
 462                     optional-lex-pairs
 463                     optional-dyn-pairs)
 464                    (process-args optional))
 465                   ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
 466                    (process-args (if rest (list rest) '())))
 467                   ((the-rest-sym) (if rest (car rest-syms) #f))
 468                   ((all-syms) (append required-syms
 469                                       optional-syms
 470                                       rest-syms))
 471                   ((all-lex-pairs) (append required-lex-pairs
 472                                            optional-lex-pairs
 473                                            rest-lex-pairs))
 474                   ((all-dyn-pairs) (append required-dyn-pairs
 475                                            optional-dyn-pairs
 476                                            rest-dyn-pairs)))
 477       (for-each (lambda (sym)
 478                   (mark-global-needed! (fluid-ref bindings-data)
 479                                        sym
 480                                        value-slot))
 481                 dynamic)
 482       (with-dynamic-bindings
 483        (fluid-ref bindings-data)
 484        dynamic
 485        (lambda ()
 486          (with-lexical-bindings
 487           (fluid-ref bindings-data)
 488           (map car all-lex-pairs)
 489           (map cdr all-lex-pairs)
 490           (lambda ()
 491             (make-lambda
 492              loc
 493              '()
 494              (make-lambda-case
 495               #f
 496               required
 497               optional
 498               rest
 499               #f
 500               (map (lambda (x) (nil-value loc)) optional)
 501               all-syms
 502               (let ((compiled-body
 503                      (list->seq loc (map compile-expr body))))
 504                 (make-seq
 505                  loc
 506                  (if rest
 507                      (make-conditional
 508                       loc
 509                       (call-primitive loc
 510                                       'null?
 511                                       (make-lexical-ref loc
 512                                                         rest
 513                                                         the-rest-sym))
 514                       (make-lexical-set loc
 515                                         rest
 516                                         the-rest-sym
 517                                         (nil-value loc))
 518                       (make-void loc))
 519                      (make-void loc))
 520                  (if (null? dynamic)
 521                      compiled-body
 522                      (let-dynamic loc
 523                                   dynamic
 524                                   value-slot
 525                                   (map (lambda (name-sym)
 526                                          (make-lexical-ref
 527                                           loc
 528                                           (car name-sym)
 529                                           (cdr name-sym)))
 530                                        all-dyn-pairs)
 531                                   compiled-body))))
 532               #f)))))))))
 533
 534 ;;; Handle the common part of defconst and defvar, that is, checking for
 535 ;;; a correct doc string and arguments as well as maybe in the future
 536 ;;; handling the docstring somehow.
 537
 538 (define (handle-var-def loc sym doc)
 539   (cond
 540    ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
 541    ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
 542    ((and (not (null? doc)) (not (string? (car doc))))
 543     (report-error loc "expected string as third argument of defvar, got"
 544                   (car doc)))
 545    ;; TODO: Handle doc string if present.
 546    (else #t)))
 547
 548 ;;; Handle macro and special operator bindings.
 549
 550 (define (find-operator sym type)
 551   (and
 552    (symbol? sym)
 553    (module-defined? (resolve-interface function-slot) sym)
 554    (let* ((op (module-ref (resolve-module function-slot) sym))
 555           (op (if (fluid? op) (fluid-ref op) op)))
 556      (if (and (pair? op) (eq? (car op) type))
 557          (cdr op)
 558          #f))))
 559
 560 ;;; See if a (backquoted) expression contains any unquotes.
 561
 562 (define (contains-unquotes? expr)
 563   (if (pair? expr)
 564       (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
 565           #t
 566           (or (contains-unquotes? (car expr))
 567               (contains-unquotes? (cdr expr))))
 568       #f))
 569
 570 ;;; Process a backquoted expression by building up the needed
 571 ;;; cons/append calls.  For splicing, it is assumed that the expression
 572 ;;; spliced in evaluates to a list.  The emacs manual does not really
 573 ;;; state either it has to or what to do if it does not, but Scheme
 574 ;;; explicitly forbids it and this seems reasonable also for elisp.
 575
 576 (define (unquote-cell? expr)
 577   (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
 578
 579 (define (unquote-splicing-cell? expr)
 580   (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
 581
 582 (define (process-backquote loc expr)
 583   (if (contains-unquotes? expr)
 584       (if (pair? expr)
 585           (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
 586               (compile-expr (cadr expr))
 587               (let* ((head (car expr))
 588                      (processed-tail (process-backquote loc (cdr expr)))
 589                      (head-is-list-2 (and (list? head)
 590                                           (= (length head) 2)))
 591                      (head-unquote (and head-is-list-2
 592                                         (unquote? (car head))))
 593                      (head-unquote-splicing (and head-is-list-2
 594                                                  (unquote-splicing?
 595                                                   (car head)))))
 596                 (if head-unquote-splicing
 597                     (call-primitive loc
 598                                     'append
 599                                     (compile-expr (cadr head))
 600                                     processed-tail)
 601                     (call-primitive loc 'cons
 602                                     (if head-unquote
 603                                         (compile-expr (cadr head))
 604                                         (process-backquote loc head))
 605                                     processed-tail))))
 606           (report-error loc
 607                         "non-pair expression contains unquotes"
 608                         expr))
 609       (make-const loc expr)))
 610
 611 ;;; Temporarily update a list of symbols that are handled specially
 612 ;;; (disabled void check or always lexical) for compiling body.  We need
 613 ;;; to handle special cases for already all / set to all and the like.
 614
 615 (define (with-added-symbols loc fluid syms body)
 616   (if (null? body)
 617       (report-error loc "symbol-list construct has empty body"))
 618   (if (not (or (eq? syms 'all)
 619                (and (list? syms) (and-map symbol? syms))))
 620       (report-error loc "invalid symbol list" syms))
 621   (let ((old (fluid-ref fluid))
 622         (make-body (lambda ()
 623                      (list->seq loc (map compile-expr body)))))
 624     (if (eq? old 'all)
 625         (make-body)
 626         (let ((new (if (eq? syms 'all)
 627                        'all
 628                        (append syms old))))
 629           (with-fluids ((fluid new))
 630             (make-body))))))
 631
 632 ;;; Special operators
 633
 634 (defspecial progn (loc args)
 635   (list->seq loc (map compile-expr args)))
 636
 637 (defspecial if (loc args)
 638   (pmatch args
 639     ((,cond ,then . ,else)
 640      (make-conditional loc
 641                        (compile-expr cond)
 642                        (compile-expr then)
 643                        (if (null? else)
 644                            (nil-value loc)
 645                            (list->seq loc (map compile-expr else)))))))
 646
 647 (defspecial defconst (loc args)
 648   (pmatch args
 649     ((,sym ,value . ,doc)
 650      (if (handle-var-def loc sym doc)
 651          (make-seq loc
 652                         (set-variable! loc
 653                                        sym
 654                                        value-slot
 655                                        (compile-expr value))
 656                         (make-const loc sym))))))
 657
 658 (defspecial defvar (loc args)
 659   (pmatch args
 660     ((,sym) (make-const loc sym))
 661     ((,sym ,value . ,doc)
 662      (if (handle-var-def loc sym doc)
 663          (make-seq
 664           loc
 665           (make-conditional
 666            loc
 667            (make-conditional
 668             loc
 669             (call-primitive
 670              loc
 671              'module-bound?
 672              (call-primitive loc
 673                              'resolve-interface
 674                              (make-const loc value-slot))
 675              (make-const loc sym))
 676             (call-primitive loc
 677                             'fluid-bound?
 678                             (make-module-ref loc value-slot sym #t))
 679             (make-const loc #f))
 680            (make-void loc)
 681            (set-variable! loc sym value-slot (compile-expr value)))
 682           (make-const loc sym))))))
 683
 684 (defspecial setq (loc args)
 685   (define (car* x) (if (null? x) '() (car x)))
 686   (define (cdr* x) (if (null? x) '() (cdr x)))
 687   (define (cadr* x) (car* (cdr* x)))
 688   (define (cddr* x) (cdr* (cdr* x)))
 689   (list->seq
 690    loc
 691    (let loop ((args args) (last (nil-value loc)))
 692      (if (null? args)
 693          (list last)
 694          (let ((sym (car args))
 695                (val (compile-expr (cadr* args))))
 696            (if (not (symbol? sym))
 697                (report-error loc "expected symbol in setq")
 698                (cons
 699                 (set-variable! loc sym value-slot val)
 700                 (loop (cddr* args)
 701                       (reference-variable loc sym value-slot)))))))))
 702
 703 (defspecial let (loc args)
 704   (pmatch args
 705     ((,bindings . ,body)
 706      (generate-let loc value-slot bindings body))))
 707
 708 (defspecial lexical-let (loc args)
 709   (pmatch args
 710     ((,bindings . ,body)
 711      (generate-let loc 'lexical bindings body))))
 712
 713 (defspecial flet (loc args)
 714   (pmatch args
 715     ((,bindings . ,body)
 716      (generate-let loc function-slot bindings body))))
 717
 718 (defspecial let* (loc args)
 719   (pmatch args
 720     ((,bindings . ,body)
 721      (generate-let* loc value-slot bindings body))))
 722
 723 (defspecial lexical-let* (loc args)
 724   (pmatch args
 725     ((,bindings . ,body)
 726      (generate-let* loc 'lexical bindings body))))
 727
 728 (defspecial flet* (loc args)
 729   (pmatch args
 730     ((,bindings . ,body)
 731      (generate-let* loc function-slot bindings body))))
 732
 733 ;;; Temporarily set symbols as always lexical only for the lexical scope
 734 ;;; of a construct.
 735
 736 (defspecial with-always-lexical (loc args)
 737   (pmatch args
 738     ((,syms . ,body)
 739      (with-added-symbols loc always-lexical syms body))))
 740
 741 ;;; guile-ref allows building TreeIL's module references from within
 742 ;;; elisp as a way to access data within the Guile universe.  The module
 743 ;;; and symbol referenced are static values, just like (@ module symbol)
 744 ;;; does!
 745
 746 (defspecial guile-ref (loc args)
 747   (pmatch args
 748     ((,module ,sym) (guard (and (list? module) (symbol? sym)))
 749      (make-module-ref loc module sym #t))))
 750
 751 ;;; guile-primitive allows to create primitive references, which are
 752 ;;; still a little faster.
 753
 754 (defspecial guile-primitive (loc args)
 755   (pmatch args
 756     ((,sym)
 757      (make-primitive-ref loc sym))))
 758
 759 ;;; A while construct is transformed into a tail-recursive loop like
 760 ;;; this:
 761 ;;;
 762 ;;; (letrec ((iterate (lambda ()
 763 ;;;                     (if condition
 764 ;;;                       (begin body
 765 ;;;                              (iterate))
 766 ;;;                       #nil))))
 767 ;;;   (iterate))
 768 ;;;
 769 ;;; As letrec is not directly accessible from elisp, while is
 770 ;;; implemented here instead of with a macro.
 771
 772 (defspecial while (loc args)
 773   (pmatch args
 774     ((,condition . ,body)
 775      (let* ((itersym (gensym))
 776             (compiled-body (map compile-expr body))
 777             (iter-call (make-call loc
 778                                   (make-lexical-ref loc
 779                                                     'iterate
 780                                                     itersym)
 781                                   (list)))
 782             (full-body (list->seq loc `(,@compiled-body ,iter-call)))
 783             (lambda-body (make-conditional loc
 784                                            (compile-expr condition)
 785                                            full-body
 786                                            (nil-value loc)))
 787             (iter-thunk (make-lambda loc
 788                                      '()
 789                                      (make-lambda-case #f
 790                                                        '()
 791                                                        #f
 792                                                        #f
 793                                                        #f
 794                                                        '()
 795                                                        '()
 796                                                        lambda-body
 797                                                        #f))))
 798        (make-letrec loc
 799                     #f
 800                     '(iterate)
 801                     (list itersym)
 802                     (list iter-thunk)
 803                     iter-call)))))
 804
 805 (defspecial function (loc args)
 806   (pmatch args
 807     (((lambda ,args . ,body))
 808      (compile-lambda loc args body))
 809     ((,sym) (guard (symbol? sym))
 810      (reference-variable loc sym function-slot))))
 811
 812 (defspecial defmacro (loc args)
 813   (pmatch args
 814     ((,name ,args . ,body)
 815      (if (not (symbol? name))
 816          (report-error loc "expected symbol as macro name" name)
 817          (let* ((tree-il
 818                  (make-seq
 819                   loc
 820                   (set-variable!
 821                    loc
 822                    name
 823                    function-slot
 824                    (make-primcall loc 'cons
 825                                   (list (make-const loc 'macro)
 826                                         (compile-lambda loc args body))))
 827                   (make-const loc name))))
 828            (compile (ensuring-globals loc bindings-data tree-il)
 829                     #:from 'tree-il
 830                     #:to 'value)
 831            tree-il)))))
 832
 833 (defspecial defun (loc args)
 834   (pmatch args
 835     ((,name ,args . ,body)
 836      (if (not (symbol? name))
 837          (report-error loc "expected symbol as function name" name)
 838          (make-seq loc
 839                    (set-variable! loc
 840                                   name
 841                                   function-slot
 842                                   (compile-lambda loc
 843                                                   args
 844                                                   body))
 845                    (make-const loc name))))))
 846
 847 (defspecial #{`}# (loc args)
 848   (pmatch args
 849     ((,val)
 850      (process-backquote loc val))))
 851
 852 (defspecial quote (loc args)
 853   (pmatch args
 854     ((,val)
 855      (make-const loc val))))
 856
 857 ;;; Compile a compound expression to Tree-IL.
 858
 859 (define (compile-pair loc expr)
 860   (let ((operator (car expr))
 861         (arguments (cdr expr)))
 862     (cond
 863      ((find-operator operator 'special-operator)
 864       => (lambda (special-operator-function)
 865            (special-operator-function loc arguments)))
 866      ((find-operator operator 'macro)
 867       => (lambda (macro-function)
 868            (compile-expr (apply macro-function arguments))))
 869      (else
 870       (make-call loc
 871                  (if (symbol? operator)
 872                      (reference-variable loc
 873                                          operator
 874                                          function-slot)
 875                      (compile-expr operator))
 876                  (map compile-expr arguments))))))
 877
 878 ;;; Compile a symbol expression.  This is a variable reference or maybe
 879 ;;; some special value like nil.
 880
 881 (define (compile-symbol loc sym)
 882   (case sym
 883     ((nil) (nil-value loc))
 884     ((t) (t-value loc))
 885     (else (reference-variable loc sym value-slot))))
 886
 887 ;;; Compile a single expression to TreeIL.
 888
 889 (define (compile-expr expr)
 890   (let ((loc (location expr)))
 891     (cond
 892      ((symbol? expr)
 893       (compile-symbol loc expr))
 894      ((pair? expr)
 895       (compile-pair loc expr))
 896      (else (make-const loc expr)))))
 897
 898 ;;; Process the compiler options.
 899 ;;; FIXME: Why is '(()) passed as options by the REPL?
 900
 901 (define (valid-symbol-list-arg? value)
 902   (or (eq? value 'all)
 903       (and (list? value) (and-map symbol? value))))
 904
 905 (define (process-options! opt)
 906   (if (and (not (null? opt))
 907            (not (equal? opt '(()))))
 908       (if (null? (cdr opt))
 909           (report-error #f "Invalid compiler options" opt)
 910           (let ((key (car opt))
 911                 (value (cadr opt)))
 912             (case key
 913               ((#:warnings)             ; ignore
 914                #f)
 915               ((#:always-lexical)
 916                (if (valid-symbol-list-arg? value)
 917                    (fluid-set! always-lexical value)
 918                    (report-error #f
 919                                  "Invalid value for #:always-lexical"
 920                                  value)))
 921               (else (report-error #f
 922                                   "Invalid compiler option"
 923                                   key)))))))
 924
 925 ;;; Entry point for compilation to TreeIL.  This creates the bindings
 926 ;;; data structure, and after compiling the main expression we need to
 927 ;;; make sure all globals for symbols used during the compilation are
 928 ;;; created using the generate-ensure-global function.
 929
 930 (define (compile-tree-il expr env opts)
 931   (values
 932    (with-fluids ((bindings-data (make-bindings))
 933                  (disable-void-check '())
 934                  (always-lexical '()))
 935      (process-options! opts)
 936      (let ((compiled (compile-expr expr)))
 937       (ensuring-globals (location expr) bindings-data compiled)))
 938    env
 939    env))