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

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