[bpt/guile.git] / module / language / elisp / compile-tree-il.scm

;;; Guile Emacs Lisp

;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(define-module (language elisp compile-tree-il)
  #:use-module (language elisp bindings)
  #:use-module (language elisp runtime)
  #:use-module (language tree-il)
  #:use-module (system base pmatch)
  #:use-module (system base compile)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-8)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (compile-tree-il
            compile-progn
            compile-if
            compile-defconst
            compile-defvar
            compile-setq
            compile-let
            compile-lexical-let
            compile-flet
            compile-let*
            compile-lexical-let*
            compile-flet*
            compile-without-void-checks
            compile-with-always-lexical
            compile-guile-ref
            compile-guile-primitive
            compile-while
            compile-function
            compile-defmacro
            compile-defun
            #{compile-`}#
            compile-quote))

;;; Certain common parameters (like the bindings data structure or
;;; compiler options) are not always passed around but accessed using
;;; fluids to simulate dynamic binding (hey, this is about elisp).

;;; The bindings data structure to keep track of symbol binding related
;;; data.

(define bindings-data (make-fluid))

;;; Store for which symbols (or all/none) void checks are disabled.

(define disable-void-check (make-fluid))

;;; Store which symbols (or all/none) should always be bound lexically,
;;; even with ordinary let and as lambda arguments.

(define always-lexical (make-fluid))

;;; Find the source properties of some parsed expression if there are
;;; any associated with it.

(define (location x)
  (and (pair? x)
       (let ((props (source-properties x)))
         (and (not (null? props))
              props))))

;;; Values to use for Elisp's nil and t.

(define (nil-value loc)
  (make-const loc (@ (language elisp runtime) nil-value)))

(define (t-value loc)
  (make-const loc (@ (language elisp runtime) t-value)))

;;; Modules that contain the value and function slot bindings.

(define runtime '(language elisp runtime))

(define value-slot (@ (language elisp runtime) value-slot-module))

(define function-slot (@ (language elisp runtime) function-slot-module))

;;; The backquoting works the same as quasiquotes in Scheme, but the
;;; forms are named differently; to make easy adaptions, we define these
;;; predicates checking for a symbol being the car of an
;;; unquote/unquote-splicing/backquote form.

(define (unquote? sym)
  (and (symbol? sym) (eq? sym '#{,}#)))

(define (unquote-splicing? sym)
  (and (symbol? sym) (eq? sym '#{,@}#)))

;;; Build a call to a primitive procedure nicely.

(define (call-primitive loc sym . args)
  (make-application loc (make-primitive-ref loc sym) args))

;;; Error reporting routine for syntax/compilation problems or build
;;; code for a runtime-error output.

(define (report-error loc . args)
  (apply error args))

(define (runtime-error loc msg . args)
  (make-application loc
                    (make-primitive-ref loc 'error)
                    (cons (make-const loc msg) args)))

;;; Generate code to ensure a global symbol is there for further use of
;;; a given symbol.  In general during the compilation, those needed are
;;; only tracked with the bindings data structure.  Afterwards, however,
;;; for all those needed symbols the globals are really generated with
;;; this routine.

(define (generate-ensure-global loc sym module)
  (make-application loc
                    (make-module-ref loc runtime 'ensure-fluid! #t)
                    (list (make-const loc module)
                          (make-const loc sym))))

(define (ensuring-globals loc bindings body)
  (make-sequence
   loc
   `(,@(map-globals-needed (fluid-ref bindings)
                           (lambda (mod sym)
                             (generate-ensure-global loc sym mod)))
     ,body)))

;;; See if we should do a void-check for a given variable.  That means,
;;; check that this check is not disabled via the compiler options for
;;; this symbol.  Disabling of void check is only done for the value-slot
;;; module!

(define (want-void-check? sym module)
  (let ((disabled (fluid-ref disable-void-check)))
    (or (not (equal? module value-slot))
        (and (not (eq? disabled 'all))
             (not (memq sym disabled))))))

;;; Build a construct that establishes dynamic bindings for certain
;;; variables.  We may want to choose between binding with fluids and
;;; with-fluids* and using just ordinary module symbols and
;;; setting/reverting their values with a dynamic-wind.

(define (let-dynamic loc syms module vals body)
  (call-primitive
   loc
   'with-fluids*
   (make-application loc
                     (make-primitive-ref loc 'list)
                     (map (lambda (sym)
                            (make-module-ref loc module sym #t))
                          syms))
   (make-application loc (make-primitive-ref loc 'list) vals)
   (make-lambda loc
                '()
                (make-lambda-case #f '() #f #f #f '() '() body #f))))

;;; Handle access to a variable (reference/setting) correctly depending
;;; on whether it is currently lexically or dynamically bound.  lexical
;;; access is done only for references to the value-slot module!

(define (access-variable loc sym module handle-lexical handle-dynamic)
  (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
    (if (and lexical (equal? module value-slot))
        (handle-lexical lexical)
        (handle-dynamic))))

;;; Generate code to reference a variable.  For references in the
;;; value-slot module, we may want to generate a lexical reference
;;; instead if the variable has a lexical binding.

(define (reference-variable loc sym module)
  (access-variable
   loc
   sym
   module
   (lambda (lexical) (make-lexical-ref loc lexical lexical))
   (lambda ()
     (mark-global-needed! (fluid-ref bindings-data) sym module)
     (call-primitive loc
                     'fluid-ref
                     (make-module-ref loc module sym #t)))))

;;; Reference a variable and error if the value is void.

(define (reference-with-check loc sym module)
  (if (want-void-check? sym module)
      (let ((var (gensym)))
        (make-let
         loc
         '(value)
         `(,var)
         `(,(reference-variable loc sym module))
         (make-conditional
          loc
          (call-primitive loc
                          'eq?
                          (make-module-ref loc runtime 'void #t)
                          (make-lexical-ref loc 'value var))
          (runtime-error loc "variable is void:" (make-const loc sym))
          (make-lexical-ref loc 'value var))))
      (reference-variable loc sym module)))

;;; Generate code to set a variable.  Just as with reference-variable, in
;;; case of a reference to value-slot, we want to generate a lexical set
;;; when the variable has a lexical binding.

(define (set-variable! loc sym module value)
  (access-variable
   loc
   sym
   module
   (lambda (lexical) (make-lexical-set loc lexical lexical value))
   (lambda ()
     (mark-global-needed! (fluid-ref bindings-data) sym module)
     (call-primitive loc
                     'fluid-set!
                     (make-module-ref loc module sym #t)
                     value))))

;;; Process the bindings part of a let or let* expression; that is,
;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
;;; . val2) ...).

(define (process-let-bindings loc bindings)
  (map
   (lambda (b)
     (if (symbol? b)
         (cons b 'nil)
         (if (or (not (list? b))
                 (not (= (length b) 2)))
             (report-error
              loc
              "expected symbol or list of 2 elements in let")
             (if (not (symbol? (car b)))
                 (report-error loc "expected symbol in let")
                 (cons (car b) (cadr b))))))
   bindings))

;;; Split the let bindings into a list to be done lexically and one
;;; dynamically.  A symbol will be bound lexically if and only if: We're
;;; processing a lexical-let (i.e. module is 'lexical), OR we're
;;; processing a value-slot binding AND the symbol is already lexically
;;; bound or it is always lexical.

(define (bind-lexically? sym module)
  (or (eq? module 'lexical)
      (and (equal? module value-slot)
           (let ((always (fluid-ref always-lexical)))
             (or (eq? always 'all)
                 (memq sym always)
                 (get-lexical-binding (fluid-ref bindings-data) sym))))))

(define (split-let-bindings bindings module)
  (let iterate ((tail bindings)
                (lexical '())
                (dynamic '()))
    (if (null? tail)
        (values (reverse lexical) (reverse dynamic))
        (if (bind-lexically? (caar tail) module)
            (iterate (cdr tail) (cons (car tail) lexical) dynamic)
            (iterate (cdr tail) lexical (cons (car tail) dynamic))))))

;;; Compile let and let* expressions.  The code here is used both for
;;; let/let* and flet/flet*, just with a different bindings module.
;;;
;;; A special module value 'lexical means that we're doing a lexical-let
;;; instead and the bindings should not be saved to globals at all but
;;; be done with the lexical framework instead.

;;; Let is done with a single call to let-dynamic binding them locally
;;; to new values all "at once".  If there is at least one variable to
;;; bind lexically among the bindings, we first do a let for all of them
;;; to evaluate all values before any bindings take place, and then call
;;; let-dynamic for the variables to bind dynamically.

(define (generate-let loc module bindings body)
  (let ((bind (process-let-bindings loc bindings)))
    (call-with-values
        (lambda () (split-let-bindings bind module))
      (lambda (lexical dynamic)
        (for-each (lambda (sym)
                    (mark-global-needed! (fluid-ref bindings-data)
                                         sym
                                         module))
                  (map car dynamic))
        (let ((make-values (lambda (for)
                             (map (lambda (el) (compile-expr (cdr el)))
                                  for)))
              (make-body (lambda ()
                           (make-sequence loc (map compile-expr body)))))
          (if (null? lexical)
              (let-dynamic loc (map car dynamic) module
                           (make-values dynamic) (make-body))
              (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
                     (dynamic-syms (map (lambda (el) (gensym)) dynamic))
                     (all-syms (append lexical-syms dynamic-syms))
                     (vals (append (make-values lexical)
                                   (make-values dynamic))))
                (make-let loc
                          all-syms
                          all-syms
                          vals
                          (with-lexical-bindings
                           (fluid-ref bindings-data)
                           (map car lexical) lexical-syms
                           (lambda ()
                             (if (null? dynamic)
                                 (make-body)
                                 (let-dynamic loc
                                              (map car dynamic)
                                              module
                                              (map
                                               (lambda (sym)
                                                 (make-lexical-ref loc
                                                                   sym
                                                                   sym))
                                               dynamic-syms)
                                              (make-body)))))))))))))

;;; Let* is compiled to a cascaded set of "small lets" for each binding
;;; in turn so that each one already sees the preceding bindings.

(define (generate-let* loc module bindings body)
  (let ((bind (process-let-bindings loc bindings)))
    (begin
      (for-each (lambda (sym)
                  (if (not (bind-lexically? sym module))
                      (mark-global-needed! (fluid-ref bindings-data)
                                           sym
                                           module)))
                (map car bind))
      (let iterate ((tail bind))
        (if (null? tail)
            (make-sequence loc (map compile-expr body))
            (let ((sym (caar tail))
                  (value (compile-expr (cdar tail))))
              (if (bind-lexically? sym module)
                  (let ((target (gensym)))
                    (make-let loc
                              `(,target)
                              `(,target)
                              `(,value)
                              (with-lexical-bindings
                               (fluid-ref bindings-data)
                               `(,sym)
                               `(,target)
                               (lambda () (iterate (cdr tail))))))
                  (let-dynamic loc
                               `(,(caar tail))
                               module
                               `(,value)
                               (iterate (cdr tail))))))))))

;;; Split the argument list of a lambda expression into required,
;;; optional and rest arguments and also check it is actually valid.
;;; Additionally, we create a list of all "local variables" (that is,
;;; required, optional and rest arguments together) and also this one
;;; split into those to be bound lexically and dynamically.  Returned is
;;; as multiple values: required optional rest lexical dynamic

(define (bind-arg-lexical? arg)
  (let ((always (fluid-ref always-lexical)))
    (or (eq? always 'all)
        (memq arg always))))

(define (split-lambda-arguments loc args)
  (let iterate ((tail args)
                (mode 'required)
                (required '())
                (optional '())
                (lexical '())
                (dynamic '()))
    (cond
     ((null? tail)
      (let ((final-required (reverse required))
            (final-optional (reverse optional))
            (final-lexical (reverse lexical))
            (final-dynamic (reverse dynamic)))
        (values final-required
                final-optional
                #f
                final-lexical
                final-dynamic)))
     ((and (eq? mode 'required)
           (eq? (car tail) '&optional))
      (iterate (cdr tail) 'optional required optional lexical dynamic))
     ((eq? (car tail) '&rest)
      (if (or (null? (cdr tail))
              (not (null? (cddr tail))))
          (report-error loc "expected exactly one symbol after &rest")
          (let* ((rest (cadr tail))
                 (rest-lexical (bind-arg-lexical? rest))
                 (final-required (reverse required))
                 (final-optional (reverse optional))
                 (final-lexical (reverse (if rest-lexical
                                             (cons rest lexical)
                                             lexical)))
                 (final-dynamic (reverse (if rest-lexical
                                             dynamic
                                             (cons rest dynamic)))))
            (values final-required
                    final-optional
                    rest
                    final-lexical
                    final-dynamic))))
     (else
      (if (not (symbol? (car tail)))
          (report-error loc
                        "expected symbol in argument list, got"
                        (car tail))
          (let* ((arg (car tail))
                 (bind-lexical (bind-arg-lexical? arg))
                 (new-lexical (if bind-lexical
                                  (cons arg lexical)
                                  lexical))
                 (new-dynamic (if bind-lexical
                                  dynamic
                                  (cons arg dynamic))))
            (case mode
              ((required) (iterate (cdr tail) mode
                                   (cons arg required) optional
                                   new-lexical new-dynamic))
              ((optional) (iterate (cdr tail) mode
                                   required (cons arg optional)
                                   new-lexical new-dynamic))
              (else
               (error "invalid mode in split-lambda-arguments"
                      mode)))))))))

;;; Compile a lambda expression.  One thing we have to be aware of is
;;; that lambda arguments are usually dynamically bound, even when a
;;; lexical binding is intact for a symbol.  For symbols that are marked
;;; as 'always lexical,' however, we lexically bind here as well, and
;;; thus we get them out of the let-dynamic call and register a lexical
;;; binding for them (the lexical target variable is already there,
;;; namely the real lambda argument from TreeIL).

(define (compile-lambda loc args body)
  (if (not (list? args))
      (report-error loc "expected list for argument-list" args))
  (if (null? body)
      (report-error loc "function body must not be empty"))
  (receive (required optional rest lexical dynamic)
           (split-lambda-arguments loc args)
    (define (process-args args)
      (define (find-pairs pairs filter)
        (lset-intersection (lambda (name+sym x)
                             (eq? (car name+sym) x))
                           pairs
                           filter))
      (let* ((syms (map (lambda (x) (gensym)) args))
             (pairs (map cons args syms))
             (lexical-pairs (find-pairs pairs lexical))
             (dynamic-pairs (find-pairs pairs dynamic)))
        (values syms pairs lexical-pairs dynamic-pairs)))
    (let*-values (((required-syms
                    required-pairs
                    required-lex-pairs
                    required-dyn-pairs)
                   (process-args required))
                  ((optional-syms
                    optional-pairs
                    optional-lex-pairs
                    optional-dyn-pairs)
                   (process-args optional))
                  ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
                   (process-args (if rest (list rest) '())))
                  ((the-rest-sym) (if rest (car rest-syms) #f))
                  ((all-syms) (append required-syms
                                      optional-syms
                                      rest-syms))
                  ((all-lex-pairs) (append required-lex-pairs
                                           optional-lex-pairs
                                           rest-lex-pairs))
                  ((all-dyn-pairs) (append required-dyn-pairs
                                           optional-dyn-pairs
                                           rest-dyn-pairs)))
      (for-each (lambda (sym)
                  (mark-global-needed! (fluid-ref bindings-data)
                                       sym
                                       value-slot))
                dynamic)
      (with-dynamic-bindings
       (fluid-ref bindings-data)
       dynamic
       (lambda ()
         (with-lexical-bindings
          (fluid-ref bindings-data)
          (map car all-lex-pairs)
          (map cdr all-lex-pairs)
          (lambda ()
            (make-lambda
             loc
             '()
             (make-lambda-case
              #f
              required
              optional
              rest
              #f
              (map (lambda (x) (nil-value loc)) optional)
              all-syms
              (let ((compiled-body
                     (make-sequence loc (map compile-expr body))))
                (make-sequence
                 loc
                 (list
                  (if rest
                      (make-conditional
                       loc
                       (call-primitive loc
                                       'null?
                                       (make-lexical-ref loc
                                                         rest
                                                         the-rest-sym))
                       (make-lexical-set loc
                                         rest
                                         the-rest-sym
                                         (nil-value loc))
                       (make-void loc))
                      (make-void loc))
                  (if (null? dynamic)
                      compiled-body
                      (let-dynamic loc
                                   dynamic
                                   value-slot
                                   (map (lambda (name-sym)
                                          (make-lexical-ref
                                           loc
                                           (car name-sym)
                                           (cdr name-sym)))
                                        all-dyn-pairs)
                                   compiled-body)))))
              #f)))))))))

;;; Handle the common part of defconst and defvar, that is, checking for
;;; a correct doc string and arguments as well as maybe in the future
;;; handling the docstring somehow.

(define (handle-var-def loc sym doc)
  (cond
   ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
   ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
   ((and (not (null? doc)) (not (string? (car doc))))
    (report-error loc "expected string as third argument of defvar, got"
                  (car doc)))
   ;; TODO: Handle doc string if present.
   (else #t)))

;;; Handle macro and special operator bindings.

(define (find-operator sym type)
  (and
   (symbol? sym)
   (module-defined? (resolve-interface function-slot) sym)
   (let* ((op (module-ref (resolve-module function-slot) sym))
          (op (if (fluid? op) (fluid-ref op) op)))
     (if (and (pair? op) (eq? (car op) type))
         (cdr op)
         #f))))

;;; See if a (backquoted) expression contains any unquotes.

(define (contains-unquotes? expr)
  (if (pair? expr)
      (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
          #t
          (or (contains-unquotes? (car expr))
              (contains-unquotes? (cdr expr))))
      #f))

;;; Process a backquoted expression by building up the needed
;;; cons/append calls.  For splicing, it is assumed that the expression
;;; spliced in evaluates to a list.  The emacs manual does not really
;;; state either it has to or what to do if it does not, but Scheme
;;; explicitly forbids it and this seems reasonable also for elisp.

(define (unquote-cell? expr)
  (and (list? expr) (= (length expr) 2) (unquote? (car expr))))

(define (unquote-splicing-cell? expr)
  (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))

(define (process-backquote loc expr)
  (if (contains-unquotes? expr)
      (if (pair? expr)
          (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
              (compile-expr (cadr expr))
              (let* ((head (car expr))
                     (processed-tail (process-backquote loc (cdr expr)))
                     (head-is-list-2 (and (list? head)
                                          (= (length head) 2)))
                     (head-unquote (and head-is-list-2
                                        (unquote? (car head))))
                     (head-unquote-splicing (and head-is-list-2
                                                 (unquote-splicing?
                                                  (car head)))))
                (if head-unquote-splicing
                    (call-primitive loc
                                    'append
                                    (compile-expr (cadr head))
                                    processed-tail)
                    (call-primitive loc 'cons
                                    (if head-unquote
                                        (compile-expr (cadr head))
                                        (process-backquote loc head))
                                    processed-tail))))
          (report-error loc
                        "non-pair expression contains unquotes"
                        expr))
      (make-const loc expr)))

;;; Temporarily update a list of symbols that are handled specially
;;; (disabled void check or always lexical) for compiling body.  We need
;;; to handle special cases for already all / set to all and the like.

(define (with-added-symbols loc fluid syms body)
  (if (null? body)
      (report-error loc "symbol-list construct has empty body"))
  (if (not (or (eq? syms 'all)
               (and (list? syms) (and-map symbol? syms))))
      (report-error loc "invalid symbol list" syms))
  (let ((old (fluid-ref fluid))
        (make-body (lambda ()
                     (make-sequence loc (map compile-expr body)))))
    (if (eq? old 'all)
        (make-body)
        (let ((new (if (eq? syms 'all)
                       'all
                       (append syms old))))
          (with-fluids ((fluid new))
            (make-body))))))

;;; Special operators

(defspecial progn (loc args)
  (make-sequence loc (map compile-expr args)))

(defspecial if (loc args)
  (pmatch args
    ((,cond ,then . ,else)
     (make-conditional loc
                       (compile-expr cond)
                       (compile-expr then)
                       (if (null? else)
                           (nil-value loc)
                           (make-sequence loc
                                          (map compile-expr else)))))))

(defspecial defconst (loc args)
  (pmatch args
    ((,sym ,value . ,doc)
     (if (handle-var-def loc sym doc)
         (make-sequence loc
                        (list (set-variable! loc
                                             sym
                                             value-slot
                                             (compile-expr value))
                              (make-const loc sym)))))))

(defspecial defvar (loc args)
  (pmatch args
    ((,sym) (make-const loc sym))
    ((,sym ,value . ,doc)
     (if (handle-var-def loc sym doc)
         (make-sequence
          loc
          (list (make-conditional
                 loc
                 (call-primitive loc
                                 'eq?
                                 (make-module-ref loc runtime 'void #t)
                                 (reference-variable loc sym value-slot))
                 (set-variable! loc sym value-slot (compile-expr value))
                 (make-void loc))
                (make-const loc sym)))))))

(defspecial setq (loc args)
  (define (car* x) (if (null? x) '() (car x)))
  (define (cdr* x) (if (null? x) '() (cdr x)))
  (define (cadr* x) (car* (cdr* x)))
  (define (cddr* x) (cdr* (cdr* x)))
  (make-sequence
   loc
   (let loop ((args args) (last (nil-value loc)))
     (if (null? args)
         (list last)
         (let ((sym (car args))
               (val (compile-expr (cadr* args))))
           (if (not (symbol? sym))
               (report-error loc "expected symbol in setq")
               (cons
                (set-variable! loc sym value-slot val)
                (loop (cddr* args)
                      (reference-variable loc sym value-slot)))))))))
  
(defspecial let (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let loc value-slot bindings body))))

(defspecial lexical-let (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let loc 'lexical bindings body))))

(defspecial flet (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let loc function-slot bindings body))))

(defspecial let* (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let* loc value-slot bindings body))))

(defspecial lexical-let* (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let* loc 'lexical bindings body))))

(defspecial flet* (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let* loc function-slot bindings body))))

;;; Temporarily disable void checks or set symbols as always lexical
;;; only for the lexical scope of a construct.

(defspecial without-void-checks (loc args)
  (pmatch args
    ((,syms . ,body)
     (with-added-symbols loc disable-void-check syms body))))

(defspecial with-always-lexical (loc args)
  (pmatch args
    ((,syms . ,body)
     (with-added-symbols loc always-lexical syms body))))

;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe.  The module
;;; and symbol referenced are static values, just like (@ module symbol)
;;; does!

(defspecial guile-ref (loc args)
  (pmatch args
    ((,module ,sym) (guard (and (list? module) (symbol? sym)))
     (make-module-ref loc module sym #t))))

;;; guile-primitive allows to create primitive references, which are
;;; still a little faster.

(defspecial guile-primitive (loc args)
  (pmatch args
    ((,sym)
     (make-primitive-ref loc sym))))

;;; A while construct is transformed into a tail-recursive loop like
;;; this:
;;;
;;; (letrec ((iterate (lambda ()
;;;                     (if condition
;;;                       (begin body
;;;                              (iterate))
;;;                       #nil))))
;;;   (iterate))
;;;
;;; As letrec is not directly accessible from elisp, while is
;;; implemented here instead of with a macro.

(defspecial while (loc args)
  (pmatch args
    ((,condition . ,body)
     (let* ((itersym (gensym))
            (compiled-body (map compile-expr body))
            (iter-call (make-application loc
                                         (make-lexical-ref loc
                                                           'iterate
                                                           itersym)
                                         (list)))
            (full-body (make-sequence loc
                                      `(,@compiled-body ,iter-call)))
            (lambda-body (make-conditional loc
                                           (compile-expr condition)
                                           full-body
                                           (nil-value loc)))
            (iter-thunk (make-lambda loc
                                     '()
                                     (make-lambda-case #f
                                                       '()
                                                       #f
                                                       #f
                                                       #f
                                                       '()
                                                       '()
                                                       lambda-body
                                                       #f))))
       (make-letrec loc
                    #f
                    '(iterate)
                    (list itersym)
                    (list iter-thunk)
                    iter-call)))))

(defspecial function (loc args)
  (pmatch args
    (((lambda ,args . ,body))
     (compile-lambda loc args body))))

(defspecial defmacro (loc args)
  (pmatch args
    ((,name ,args . ,body)
     (if (not (symbol? name))
         (report-error loc "expected symbol as macro name" name)
         (let* ((tree-il
                 (make-sequence
                  loc
                  (list
                   (set-variable!
                    loc
                    name
                    function-slot
                    (make-application
                     loc
                     (make-module-ref loc '(guile) 'cons #t)
                     (list (make-const loc 'macro)
                           (compile-lambda loc args body))))
                   (make-const loc name)))))
           (compile (ensuring-globals loc bindings-data tree-il)
                    #:from 'tree-il
                    #:to 'value)
           tree-il)))))

(defspecial defun (loc args)
  (pmatch args
    ((,name ,args . ,body)
     (if (not (symbol? name))
         (report-error loc "expected symbol as function name" name)
         (make-sequence loc
                        (list (set-variable! loc
                                             name
                                             function-slot
                                             (compile-lambda loc
                                                             args
                                                             body))
                              (make-const loc name)))))))

(defspecial #{`}# (loc args)
  (pmatch args
    ((,val)
     (process-backquote loc val))))

(defspecial quote (loc args)
  (pmatch args
    ((,val)
     (make-const loc val))))

;;; Compile a compound expression to Tree-IL.

(define (compile-pair loc expr)
  (let ((operator (car expr))
        (arguments (cdr expr)))
    (cond
     ((find-operator operator 'special-operator)
      => (lambda (special-operator-function)
           (special-operator-function loc arguments)))
     ((find-operator operator 'macro)
      => (lambda (macro-function)
           (compile-expr (apply macro-function arguments))))
     (else
      (make-application loc
                        (if (symbol? operator)
                            (reference-with-check loc
                                                  operator
                                                  function-slot)
                            (compile-expr operator))
                        (map compile-expr arguments))))))

;;; Compile a symbol expression.  This is a variable reference or maybe
;;; some special value like nil.

(define (compile-symbol loc sym)
  (case sym
    ((nil) (nil-value loc))
    ((t) (t-value loc))
    (else (reference-with-check loc sym value-slot))))

;;; Compile a single expression to TreeIL.

(define (compile-expr expr)
  (let ((loc (location expr)))
    (cond
     ((symbol? expr)
      (compile-symbol loc expr))
     ((pair? expr)
      (compile-pair loc expr))
     (else (make-const loc expr)))))

;;; Process the compiler options.
;;; FIXME: Why is '(()) passed as options by the REPL?

(define (valid-symbol-list-arg? value)
  (or (eq? value 'all)
      (and (list? value) (and-map symbol? value))))

(define (process-options! opt)
  (if (and (not (null? opt))
           (not (equal? opt '(()))))
      (if (null? (cdr opt))
          (report-error #f "Invalid compiler options" opt)
          (let ((key (car opt))
                (value (cadr opt)))
            (case key
              ((#:warnings)             ; ignore
               #f)
              ((#:disable-void-check)
               (if (valid-symbol-list-arg? value)
                   (fluid-set! disable-void-check value)
                   (report-error #f
                                 "Invalid value for #:disable-void-check"
                                 value)))
              ((#:always-lexical)
               (if (valid-symbol-list-arg? value)
                   (fluid-set! always-lexical value)
                   (report-error #f
                                 "Invalid value for #:always-lexical"
                                 value)))
              (else (report-error #f
                                  "Invalid compiler option"
                                  key)))))))

;;; Entry point for compilation to TreeIL.  This creates the bindings
;;; data structure, and after compiling the main expression we need to
;;; make sure all globals for symbols used during the compilation are
;;; created using the generate-ensure-global function.

(define (compile-tree-il expr env opts)
  (values
   (with-fluids ((bindings-data (make-bindings))
                 (disable-void-check '())
                 (always-lexical '()))
     (process-options! opts)
     (let ((compiled (compile-expr expr)))
      (ensuring-globals (location expr) bindings-data compiled)))
   env
   env))