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