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