code:
;;; Guile Emacs Lisp

;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA

;;; Code:

(define-module (language elisp runtime macros)
  #:use-module (language elisp runtime))

;;; This module contains the macro definitions of elisp symbols. In
;;; contrast to the other runtime modules, those are used directly
;;; during compilation, of course, so not really in runtime. But I think
;;; it fits well to the others here.

(built-in-macro lambda
  (lambda cdr
    `(function (lambda ,@cdr))))

;;; The prog1 and prog2 constructs can easily be defined as macros using
;;; progn and some lexical-let's to save the intermediate value to
;;; return at the end.

(built-in-macro prog1
  (lambda (form1 . rest)
    (let ((temp (gensym)))
      `(lexical-let ((,temp ,form1))
         ,@rest
         ,temp))))

(built-in-macro prog2
  (lambda (form1 form2 . rest)
    `(progn ,form1 (prog1 ,form2 ,@rest))))

;;; Define the conditionals when and unless as macros.

(built-in-macro when
  (lambda (condition . thens)
    `(if ,condition (progn ,@thens) nil)))

(built-in-macro unless
  (lambda (condition . elses)
    `(if ,condition nil (progn ,@elses))))

;;; Impement the cond form as nested if's. A special case is a
;;; (condition) subform, in which case we need to return the condition
;;; itself if it is true and thus save it in a local variable before
;;; testing it.

(built-in-macro cond
  (lambda (. clauses)
    (let iterate ((tail clauses))
      (if (null? tail)
          'nil
          (let ((cur (car tail))
                (rest (iterate (cdr tail))))
            (prim cond
                  ((prim or (not (list? cur)) (null? cur))
                   (macro-error "invalid clause in cond" cur))
                  ((null? (cdr cur))
                   (let ((var (gensym)))
                     `(lexical-let ((,var ,(car cur)))
                        (if ,var
                            ,var
                            ,rest))))
                  (else
                   `(if ,(car cur)
                        (progn ,@(cdr cur))
                        ,rest))))))))

;;; The and and or forms can also be easily defined with macros.

(built-in-macro and
  (case-lambda
    (() 't)
    ((x) x)
    ((x . args)
     (let iterate ((x x) (tail args))
       (if (null? tail)
           x
           `(if ,x
                ,(iterate (car tail) (cdr tail))
                nil))))))

(built-in-macro or
  (case-lambda
    (() 'nil)
    ((x) x)
    ((x . args)
     (let iterate ((x x) (tail args))
       (if (null? tail)
           x
           (let ((var (gensym)))
             `(lexical-let ((,var ,x))
                (if ,var
                    ,var
                    ,(iterate (car tail) (cdr tail))))))))))

;;; Define the dotimes and dolist iteration macros.

(built-in-macro dotimes
  (lambda (args . body)
    (if (prim or
              (not (list? args))
              (< (length args) 2)
              (> (length args) 3))
        (macro-error "invalid dotimes arguments" args)
        (let ((var (car args))
              (count (cadr args)))
          (if (not (symbol? var))
              (macro-error "expected symbol as dotimes variable"))
          `(let ((,var 0))
             (while ((guile-primitive <) ,var ,count)
               ,@body
               (setq ,var ((guile-primitive 1+) ,var)))
             ,@(if (= (length args) 3)
                   (list (caddr args))
                   '()))))))

(built-in-macro dolist
  (lambda (args . body)
    (if (prim or
              (not (list? args))
              (< (length args) 2)
              (> (length args) 3))
        (macro-error "invalid dolist arguments" args)
        (let ((var (car args))
              (iter-list (cadr args))
              (tailvar (gensym)))
          (if (not (symbol? var))
              (macro-error "expected symbol as dolist variable")
              `(let (,var)
                 (lexical-let ((,tailvar ,iter-list))
                   (while ((guile-primitive not)
                           ((guile-primitive null?) ,tailvar))
                          (setq ,var ((guile-primitive car) ,tailvar))
                          ,@body
                          (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
                   ,@(if (= (length args) 3)
                         (list (caddr args))
                         '()))))))))

;;; Exception handling. unwind-protect and catch are implemented as
;;; macros (throw is a built-in function).

;;; catch and throw can mainly be implemented directly using Guile's
;;; primitives for exceptions, the only difficulty is that the keys used
;;; within Guile must be symbols, while elisp allows any value and
;;; checks for matches using eq (eq?). We handle this by using always #t
;;; as key for the Guile primitives and check for matches inside the
;;; handler; if the elisp keys are not eq?, we rethrow the exception.

(built-in-macro catch
  (lambda (tag . body)
    (if (null? body)
        (macro-error "catch with empty body"))
    (let ((tagsym (gensym)))
      `(lexical-let ((,tagsym ,tag))
         ((guile-primitive catch)
          #t
          (lambda () ,@body)
          ,(let* ((dummy-key (gensym))
                  (elisp-key (gensym))
                  (value (gensym))
                  (arglist `(,dummy-key ,elisp-key ,value)))
             `(with-always-lexical
               ,arglist
               (lambda ,arglist
                 (if (eq ,elisp-key ,tagsym)
                     ,value
                     ((guile-primitive throw) ,dummy-key ,elisp-key
                      ,value))))))))))

;;; unwind-protect is just some weaker construct as dynamic-wind, so
;;; straight-forward to implement.

(built-in-macro unwind-protect
  (lambda (body . clean-ups)
    (if (null? clean-ups)
        (macro-error "unwind-protect without cleanup code"))
    `((guile-primitive dynamic-wind)
      (lambda () nil)
      (lambda () ,body)
      (lambda () ,@clean-ups))))

;;; Pop off the first element from a list or push one to it.

(built-in-macro pop
  (lambda (list-name)
    `(prog1 (car ,list-name)
            (setq ,list-name (cdr ,list-name)))))

(built-in-macro push
  (lambda (new-el list-name)
    `(setq ,list-name (cons ,new-el ,list-name))))


code:
;;; Guile Emacs Lisp

;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA

;;; Code:

(define-module (language elisp runtime subrs)
  #:use-module (language elisp runtime)
  #:use-module (system base compile))

;;; This module contains the function-slots of elisp symbols. Elisp
;;; built-in functions are implemented as predefined function bindings
;;; here.

;;; Equivalence and equalness predicates.

(built-in-func eq
  (lambda (a b)
    (elisp-bool (eq? a b))))

(built-in-func equal
  (lambda (a b)
    (elisp-bool (equal? a b))))

;;; Number predicates.

(built-in-func floatp
  (lambda (num)
    (elisp-bool (and (real? num)
                     (or (inexact? num)
                         (prim not (integer? num)))))))

(built-in-func integerp
  (lambda (num)
    (elisp-bool (and (exact? num)
                     (integer? num)))))

(built-in-func numberp
  (lambda (num)
    (elisp-bool (real? num))))

(built-in-func wholenump
  (lambda (num)
    (elisp-bool (and (exact? num)
                     (integer? num)
                     (prim >= num 0)))))

(built-in-func zerop
  (lambda (num)
    (elisp-bool (prim = num 0))))

;;; Number comparisons.

(built-in-func =
  (lambda (num1 num2)
    (elisp-bool (prim = num1 num2))))

(built-in-func /=
  (lambda (num1 num2)
    (elisp-bool (prim not (prim = num1 num2)))))

(built-in-func <
  (lambda (num1 num2)
    (elisp-bool (prim < num1 num2))))

(built-in-func <=
  (lambda (num1 num2)
    (elisp-bool (prim <= num1 num2))))

(built-in-func >
  (lambda (num1 num2)
    (elisp-bool (prim > num1 num2))))

(built-in-func >=
  (lambda (num1 num2)
    (elisp-bool (prim >= num1 num2))))

(built-in-func max
  (lambda (. nums)
    (prim apply (@ (guile) max) nums)))

(built-in-func min
  (lambda (. nums)
    (prim apply (@ (guile) min) nums)))

(built-in-func abs
  (@ (guile) abs))

;;; Number conversion.

(built-in-func float
  (lambda (num)
    (if (exact? num)
        (exact->inexact num)
        num)))

;;; TODO: truncate, floor, ceiling, round.

;;; Arithmetic functions.

(built-in-func 1+ (@ (guile) 1+))

(built-in-func 1- (@ (guile) 1-))

(built-in-func + (@ (guile) +))

(built-in-func - (@ (guile) -))

(built-in-func * (@ (guile) *))

(built-in-func % (@ (guile) modulo))

;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
;;; values).

;;; Floating-point rounding operations.

(built-in-func ffloor (@ (guile) floor))

(built-in-func fceiling (@ (guile) ceiling))

(built-in-func ftruncate (@ (guile) truncate))

(built-in-func fround (@ (guile) round))

;;; List predicates.

(built-in-func consp
  (lambda (el)
    (elisp-bool (pair? el))))

(built-in-func atomp
  (lambda (el)
    (elisp-bool (prim not (pair? el)))))

(built-in-func listp
  (lambda (el)
    (elisp-bool (or (pair? el) (null? el)))))

(built-in-func nlistp
  (lambda (el)
    (elisp-bool (and (prim not (pair? el))
                     (prim not (null? el))))))

(built-in-func null
  (lambda (el)
    (elisp-bool (null? el))))

;;; Accessing list elements.

(built-in-func car
  (lambda (el)
    (if (null? el)
        nil-value
        (prim car el))))

(built-in-func cdr
  (lambda (el)
    (if (null? el)
        nil-value
        (prim cdr el))))

(built-in-func car-safe
  (lambda (el)
    (if (pair? el)
        (prim car el)
        nil-value)))

(built-in-func cdr-safe
  (lambda (el)
    (if (pair? el)
        (prim cdr el)
        nil-value)))

(built-in-func nth
  (lambda (n lst)
    (if (negative? n)
        (prim car lst)
        (let iterate ((i n)
                      (tail lst))
          (cond
           ((null? tail) nil-value)
           ((zero? i) (prim car tail))
           (else (iterate (prim 1- i) (prim cdr tail))))))))

(built-in-func nthcdr
  (lambda (n lst)
    (if (negative? n)
        lst
        (let iterate ((i n)
                      (tail lst))
          (cond
           ((null? tail) nil-value)
           ((zero? i) tail)
           (else (iterate (prim 1- i) (prim cdr tail))))))))

(built-in-func length (@ (guile) length))

;;; Building lists.

(built-in-func cons (@ (guile) cons))

(built-in-func list (@ (guile) list))

(built-in-func make-list
  (lambda (len obj)
    (prim make-list len obj)))

(built-in-func append (@ (guile) append))

(built-in-func reverse (@ (guile) reverse))

(built-in-func copy-tree (@ (guile) copy-tree))

(built-in-func number-sequence
  (lambda (from . rest)
    (if (prim > (prim length rest) 2)
        (runtime-error "too many arguments for number-sequence"
                       (prim cdddr rest))
        (if (null? rest)
            `(,from)
            (let ((to (prim car rest))
                  (sep (if (or (null? (prim cdr rest))
                               (eq? nil-value (prim cadr rest)))
                           1
                           (prim cadr rest))))
              (cond
               ((or (eq? nil-value to) (prim = to from)) `(,from))
               ((and (zero? sep) (prim not (prim = from to)))
                (runtime-error "infinite list in number-sequence"))
               ((prim < (prim * to sep) (prim * from sep)) '())
               (else
                (let iterate ((i (prim +
                                       from
                                       (prim *
                                             sep
                                             (prim quotient
                                                   (prim abs
                                                         (prim -
                                                               to
                                                               from))
                                                   (prim abs sep)))))
                              (result '()))
                  (if (prim = i from)
                      (prim cons i result)
                      (iterate (prim - i sep)
                               (prim cons i result)))))))))))

;;; Changing lists.

(built-in-func setcar
  (lambda (cell val)
    (if (and (null? cell) (null? val))
        #nil
        (prim set-car! cell val))
    val))

(built-in-func setcdr
  (lambda (cell val)
    (if (and (null? cell) (null? val))
        #nil
        (prim set-cdr! cell val))
    val))

;;; Accessing symbol bindings for symbols known only at runtime.

(built-in-func symbol-value
  (lambda (sym)
    (reference-variable value-slot-module sym)))

(built-in-func symbol-function
  (lambda (sym)
    (reference-variable function-slot-module sym)))

(built-in-func set
  (lambda (sym value)
    (set-variable! value-slot-module sym value)))

(built-in-func fset
  (lambda (sym value)
    (set-variable! function-slot-module sym value)))

(built-in-func makunbound
  (lambda (sym)
    (if (module-bound? (resolve-interface value-slot-module) sym)
      (let ((var (module-variable (resolve-module value-slot-module)
                                  sym)))
        (if (and (variable-bound? var) (fluid? (variable-ref var)))
            (fluid-unset! (variable-ref var))
            (variable-unset! var))))
    sym))

(built-in-func fmakunbound
  (lambda (sym)
    (if (module-bound? (resolve-interface function-slot-module) sym)
        (let ((var (module-variable
                    (resolve-module function-slot-module)
                    sym)))
          (if (and (variable-bound? var) (fluid? (variable-ref var)))
              (fluid-unset! (variable-ref var))
              (variable-unset! var))))
    sym))

(built-in-func boundp
  (lambda (sym)
    (elisp-bool
     (and
      (module-bound? (resolve-interface value-slot-module) sym)
      (let ((var (module-variable (resolve-module value-slot-module)
                                  sym)))
        (and (variable-bound? var)
             (if (fluid? (variable-ref var))
                 (fluid-bound? (variable-ref var))
                 #t)))))))

(built-in-func fboundp
  (lambda (sym)
    (elisp-bool
     (and
      (module-bound? (resolve-interface function-slot-module) sym)
      (let* ((var (module-variable (resolve-module function-slot-module)
                                   sym)))
       (and (variable-bound? var)
            (if (fluid? (variable-ref var))
                (fluid-bound? (variable-ref var))
                #t)))))))

;;; Function calls. These must take care of special cases, like using
;;; symbols or raw lambda-lists as functions!

(built-in-func apply
  (lambda (func . args)
    (let ((real-func (cond
                      ((symbol? func)
                       (reference-variable function-slot-module func))
                      ((list? func)
                       (if (and (prim not (null? func))
                                (eq? (prim car func) 'lambda))
                           (compile func #:from 'elisp #:to 'value)
                           (runtime-error "list is not a function"
                                          func)))
                      (else func))))
      (prim apply (@ (guile) apply) real-func args))))

(built-in-func funcall
  (lambda (func . args)
    (apply func args)))

;;; Throw can be implemented as built-in function.

(built-in-func throw
  (lambda (tag value)
    (prim throw 'elisp-exception tag value)))

;;; Miscellaneous.

(built-in-func not
  (lambda (x)
    (if x nil-value t-value)))

(built-in-func eval
  (lambda (form)
    (compile form #:from 'elisp #:to 'value)))

(built-in-func load
  (lambda* (file)
    (compile-file file #:from 'elisp #:to 'value)
    #t))

license: mit


code:
;;; Guile Emacs Lisp

;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA

;;; Code:

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

;;; This module contains the value-slots of elisp symbols.


code:
;;; Guile Emac Lisp

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language elisp spec)
  #:use-module (language elisp compile-tree-il)
  #:use-module (language elisp parser)
  #:use-module (system base language)
  #:export (elisp))

(define-language elisp
  #:title     "Emacs Lisp"
  #:reader    (lambda (port env) (read-elisp port))
  #:printer   write
  #:compilers `((tree-il . ,compile-tree-il)))


code:
;;; Guile Low Intermediate Language

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language glil)
  #:use-module (system base syntax)
  #:use-module (system base pmatch)
  #:use-module ((srfi srfi-1) #:select (fold))
  #:export
  (<glil-program> make-glil-program glil-program?
   glil-program-meta glil-program-body

   <glil-std-prelude> make-glil-std-prelude glil-std-prelude?
   glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label

   <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
   glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
   glil-opt-prelude-nlocs glil-opt-prelude-else-label

   <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
   glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
   glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
   glil-kw-prelude-nlocs glil-kw-prelude-else-label

   <glil-bind> make-glil-bind glil-bind?
   glil-bind-vars

   <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
   glil-mv-bind-vars glil-mv-bind-rest

   <glil-unbind> make-glil-unbind glil-unbind?

   <glil-source> make-glil-source glil-source?
   glil-source-props

   <glil-void> make-glil-void glil-void?

   <glil-const> make-glil-const glil-const?
   glil-const-obj

   <glil-lexical> make-glil-lexical glil-lexical?
   glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index

   <glil-toplevel> make-glil-toplevel glil-toplevel?
   glil-toplevel-op glil-toplevel-name

   <glil-module> make-glil-module glil-module?
   glil-module-op glil-module-mod glil-module-name glil-module-public?

   <glil-label> make-glil-label glil-label?
   glil-label-label

   <glil-branch> make-glil-branch glil-branch?
   glil-branch-inst glil-branch-label

   <glil-call> make-glil-call glil-call?
   glil-call-inst glil-call-nargs

   <glil-mv-call> make-glil-mv-call glil-mv-call?
   glil-mv-call-nargs glil-mv-call-ra

   <glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label glil-prompt-escape-only?

   parse-glil unparse-glil))

(define (print-glil x port)
  (format port "#<glil ~s>" (unparse-glil x)))

(define-type (<glil> #:printer print-glil)
  ;; Meta operations
  (<glil-program> meta body)
  (<glil-std-prelude> nreq nlocs else-label)
  (<glil-opt-prelude> nreq nopt rest nlocs else-label)
  (<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
  (<glil-bind> vars)
  (<glil-mv-bind> vars rest)
  (<glil-unbind>)
  (<glil-source> props)
  ;; Objects
  (<glil-void>)
  (<glil-const> obj)
  ;; Variables
  (<glil-lexical> local? boxed? op index)
  (<glil-toplevel> op name)
  (<glil-module> op mod name public?)
  ;; Controls
  (<glil-label> label)
  (<glil-branch> inst label)
  (<glil-call> inst nargs)
  (<glil-mv-call> nargs ra)
  (<glil-prompt> label escape-only?))

(define (parse-glil x)
  (pmatch x
    ((program ,meta . ,body)
     (make-glil-program meta (map parse-glil body)))
    ((std-prelude ,nreq ,nlocs ,else-label)
     (make-glil-std-prelude nreq nlocs else-label))
    ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
     (make-glil-opt-prelude nreq nopt rest nlocs else-label))
    ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
     (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label))
    ((bind . ,vars) (make-glil-bind vars))
    ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
    ((unbind) (make-glil-unbind))
    ((source ,props) (make-glil-source props))
    ((void) (make-glil-void))
    ((const ,obj) (make-glil-const obj))
    ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
    ((toplevel ,op ,name) (make-glil-toplevel op name))
    ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
    ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
    ((label ,label) (make-glil-label label))
    ((branch ,inst ,label) (make-glil-branch inst label))
    ((call ,inst ,nargs) (make-glil-call inst nargs))
    ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
    ((prompt ,label ,escape-only?)
     (make-glil-prompt label escape-only?))
    (else (error "invalid glil" x))))

(define (unparse-glil glil)
  (record-case glil
    ;; meta
    ((<glil-program> meta body)
     `(program ,meta ,@(map unparse-glil body)))
    ((<glil-std-prelude> nreq nlocs else-label)
     `(std-prelude ,nreq ,nlocs ,else-label))
    ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
     `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
    ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
     `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
    ((<glil-bind> vars) `(bind ,@vars))
    ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
    ((<glil-unbind>) `(unbind))
    ((<glil-source> props) `(source ,props))
    ;; constants
    ((<glil-void>) `(void))
    ((<glil-const> obj) `(const ,obj))
    ;; variables
    ((<glil-lexical> local? boxed? op index)
     `(lexical ,local? ,boxed? ,op ,index))
    ((<glil-toplevel> op name)
     `(toplevel ,op ,name))
    ((<glil-module> op mod name public?)
     `(module ,(if public? 'public 'private) ,op ,mod ,name))
    ;; controls
    ((<glil-label> label) `(label ,label))
    ((<glil-branch> inst label) `(branch ,inst ,label))
    ((<glil-call> inst nargs) `(call ,inst ,nargs))
    ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))
    ((<glil-prompt> label escape-only?)
     `(prompt ,label escape-only?))))


code:
;;; Guile VM assembler

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language glil compile-assembly)
  #:use-module (system base syntax)
  #:use-module (system base pmatch)
  #:use-module (language glil)
  #:use-module (language assembly)
  #:use-module (system vm instruction)
  #:use-module ((system vm program) #:select (make-binding))
  #:use-module (ice-9 receive)
  #:use-module ((srfi srfi-1) #:select (fold))
  #:use-module (rnrs bytevectors)
  #:export (compile-assembly))

;; Variable cache cells go in the object table, and serialize as their
;; keys. The reason we wrap the keys in these records is so they don't
;; compare as `equal?' to other objects in the object table.
;;
;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)

(define-record <variable-cache-cell> key)

;; Subprograms can be loaded into an object table as well. We need a
;; disjoint type here too. (Subprograms have their own object tables --
;; though probably we should just make one table per compilation unit.)

(define-record <subprogram> table prog)

(define (limn-sources sources)
  (let lp ((in sources) (out '()) (filename #f))
    (if (null? in)
        (reverse! out)
        (let ((addr (caar in))
              (new-filename (assq-ref (cdar in ) 'filename))
              (line (assq-ref (cdar in) 'line))
              (column (assq-ref (cdar in) 'column)))
          (cond
           ((not (equal? new-filename filename))
            (lp (cdr in)
                `((,addr . (,line . ,column))
                  (filename . ,new-filename)
                  . ,out)
                new-filename))
           ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
            (lp (cdr in)
                `((,addr . (,line . ,column))
                  . ,out)
                filename))
           (else
            (lp (cdr in) out filename)))))))

(define (make-meta bindings sources arities tail)
  ;; sounds silly, but the only case in which we have no arities is when
  ;; compiling a meta procedure.
  (if (and (null? bindings) (null? sources) (null? arities) (null? tail))
      #f
      (compile-assembly
       (make-glil-program '()
                          (list
                           (make-glil-const `(,bindings ,sources ,arities ,@tail))
                           (make-glil-call 'return 1))))))

;; A functional stack of names of live variables.
(define (make-open-binding name boxed? index)
  (list name boxed? index))
(define (make-closed-binding open-binding start end)
  (make-binding (car open-binding) (cadr open-binding)
                (caddr open-binding) start end))
(define (open-binding bindings vars start)
  (cons
   (acons start
          (map
           (lambda (v)
             (pmatch v
               ((,name ,boxed? ,i)
                (make-open-binding name boxed? i))
               (else (error "unknown binding type" v))))
           vars)
          (car bindings))
   (cdr bindings)))
(define (close-binding bindings end)
  (pmatch bindings
    ((((,start . ,closing) . ,open) . ,closed)
     (cons open
           (fold (lambda (o tail)
                   ;; the cons is for dsu sort
                   (acons start (make-closed-binding o start end)
                          tail))
                 closed
                 closing)))
    (else (error "broken bindings" bindings))))
(define (close-all-bindings bindings end)
  (if (null? (car bindings))
      (map cdr
           (stable-sort (reverse (cdr bindings))
                        (lambda (x y) (< (car x) (car y)))))
      (close-all-bindings (close-binding bindings end) end)))

;; A functional object table.
(define *module* 1)
(define (assoc-ref-or-acons alist x make-y)
  (cond ((assoc-ref alist x)
         => (lambda (y) (values y alist)))
        (else
         (let ((y (make-y x alist)))
           (values y (acons x y alist))))))
(define (object-index-and-alist x alist)
  (assoc-ref-or-acons alist x
                      (lambda (x alist)
                        (+ (length alist) *module*))))
(define (make-object-table objects)
  (and (not (null? objects))
       (list->vector (cons #f objects))))

;; A functional arities thingamajiggy.
;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
(define (open-arity addr nreq nopt rest kw arities)
  (cons
   (cond
    (kw (list addr nreq nopt rest kw))
    (rest (list addr nreq nopt rest))
    (nopt (list addr nreq nopt))
    (nreq (list addr nreq))
    (else (list addr)))
   arities))
(define (close-arity addr arities)
  (pmatch arities
    (() '())
    (((,start . ,tail) . ,rest)
     `((,start ,addr . ,tail) . ,rest))
    (else (error "bad arities" arities))))
(define (begin-arity end start nreq nopt rest kw arities)
  (open-arity start nreq nopt rest kw (close-arity end arities)))

(define (compile-assembly glil)
  (receive (code . _)
      (glil->assembly glil #t '(()) '() '() #f '() -1)
    (car code)))

(define (glil->assembly glil toplevel? bindings
                        source-alist label-alist object-alist arities addr)
  (define (emit-code x)
    (values x bindings source-alist label-alist object-alist arities))
  (define (emit-code/object x object-alist)
    (values x bindings source-alist label-alist object-alist arities))
  (define (emit-code/arity x nreq nopt rest kw)
    (values x bindings source-alist label-alist object-alist
            (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))

  (record-case glil
    ((<glil-program> meta body)
     (define (process-body)
       (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
                (label-alist '()) (object-alist (if toplevel? #f '()))
                (arities '()) (addr 0))
         (cond
          ((null? body)
           (values (reverse code)
                   (close-all-bindings bindings addr)
                   (limn-sources (reverse! source-alist))
                   (reverse label-alist)
                   (and object-alist (map car (reverse object-alist)))
                   (reverse (close-arity addr arities))
                   addr))
          (else
           (receive (subcode bindings source-alist label-alist object-alist
                     arities)
               (glil->assembly (car body) #f bindings
                               source-alist label-alist object-alist
                               arities addr)
             (lp (cdr body) (append (reverse subcode) code)
                 bindings source-alist label-alist object-alist arities
                 (addr+ addr subcode)))))))

     (receive (code bindings sources labels objects arities len)
         (process-body)
       (let* ((meta (make-meta bindings sources arities meta))
              (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
              (prog `(load-program ,labels
                                  ,(+ len meta-pad)
                                  ,meta
                                  ,@code
                                  ,@(if meta
                                        (make-list meta-pad '(nop))
                                        '()))))
         (cond
          (toplevel?
           ;; toplevel bytecode isn't loaded by the vm, no way to do
           ;; object table or closure capture (not in the bytecode,
           ;; anyway)
           (emit-code (align-program prog addr)))
          (else
           (let ((table (make-object-table objects)))
             (cond
              (object-alist
               ;; if we are being compiled from something with an object
               ;; table, cache the program there
               (receive (i object-alist)
                   (object-index-and-alist (make-subprogram table prog)
                                           object-alist)
                 (emit-code/object `(,(if (< i 256)
                                          `(object-ref ,i)
                                          `(long-object-ref ,(quotient i 256)
                                                            ,(modulo i 256))))
                                   object-alist)))
              (else
               ;; otherwise emit a load directly
               (let ((table-code (dump-object table addr)))
                 (emit-code
                  `(,@table-code
                    ,@(align-program prog (addr+ addr table-code)))))))))))))

    ((<glil-std-prelude> nreq nlocs else-label)
     (emit-code/arity
      (if (and (< nreq 8) (< nlocs (+ nreq 32)) (not else-label))
          `((assert-nargs-ee/locals ,(logior nreq (ash (- nlocs nreq) 3))))
          `(,(if else-label
                 `(br-if-nargs-ne ,(quotient nreq 256)
                                  ,(modulo nreq 256)
                                  ,else-label)
                 `(assert-nargs-ee ,(quotient nreq 256)
                                   ,(modulo nreq 256)))
            (reserve-locals ,(quotient nlocs 256)
                            ,(modulo nlocs 256))))
      nreq #f #f #f))

    ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
     (let ((bind-required
            (if else-label
                `((br-if-nargs-lt ,(quotient nreq 256)
                                  ,(modulo nreq 256)
                                  ,else-label))
                `((assert-nargs-ge ,(quotient nreq 256)
                                   ,(modulo nreq 256)))))
           (bind-optionals
            (if (zero? nopt)
                '()
                `((bind-optionals ,(quotient (+ nopt nreq) 256)
                                  ,(modulo (+ nreq nopt) 256)))))
           (bind-rest
            (cond
             (rest
              `((push-rest ,(quotient (+ nreq nopt) 256)
                           ,(modulo (+ nreq nopt) 256))))
             (else
              (if else-label
                  `((br-if-nargs-gt ,(quotient (+ nreq nopt) 256)
                                    ,(modulo (+ nreq nopt) 256)
                                    ,else-label))
                  `((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
                                     ,(modulo (+ nreq nopt) 256))))))))
       (emit-code/arity
        `(,@bind-required
          ,@bind-optionals
          ,@bind-rest
          (reserve-locals ,(quotient nlocs 256)
                          ,(modulo nlocs 256)))
        nreq nopt rest #f)))

    ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
     (receive (kw-idx object-alist)
         (object-index-and-alist kw object-alist)
       (let* ((bind-required
               (if else-label
                   `((br-if-nargs-lt ,(quotient nreq 256)
                                     ,(modulo nreq 256)
                                     ,else-label))
                   `((assert-nargs-ge ,(quotient nreq 256)
                                      ,(modulo nreq 256)))))
              (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
              (bind-optionals-and-shuffle
               `((bind-optionals/shuffle
                  ,(quotient nreq 256)
                  ,(modulo nreq 256)
                  ,(quotient (+ nreq nopt) 256)
                  ,(modulo (+ nreq nopt) 256)
                  ,(quotient ntotal 256)
                  ,(modulo ntotal 256))))
              (bind-kw
               ;; when this code gets called, all optionals are filled
               ;; in, space has been made for kwargs, and the kwargs
               ;; themselves have been shuffled above the slots for all
               ;; req/opt/kwargs locals.
               `((bind-kwargs
                  ,(quotient kw-idx 256)
                  ,(modulo kw-idx 256)
                  ,(quotient ntotal 256)
                  ,(modulo ntotal 256)
                  ,(logior (if rest 2 0)
                           (if allow-other-keys? 1 0)))))
              (bind-rest
               (if rest
                   `((bind-rest ,(quotient ntotal 256)
                                ,(modulo ntotal 256)
                                ,(quotient rest 256)
                                ,(modulo rest 256)))
                   '())))

         (let ((code `(,@bind-required
                       ,@bind-optionals-and-shuffle
                       ,@bind-kw
                       ,@bind-rest
                       (reserve-locals ,(quotient nlocs 256)
                                       ,(modulo nlocs 256)))))
           (values code bindings source-alist label-alist object-alist
                   (begin-arity addr (addr+ addr code) nreq nopt rest
                                (and kw (cons allow-other-keys? kw))
                                arities))))))

    ((<glil-bind> vars)
     (values '()
             (open-binding bindings vars addr)
             source-alist
             label-alist
             object-alist
             arities))

    ((<glil-mv-bind> vars rest)
     (if (integer? vars)
         (values `((truncate-values ,vars ,(if rest 1 0)))
                 bindings
                 source-alist
                 label-alist
                 object-alist
                 arities)
         (values `((truncate-values ,(length vars) ,(if rest 1 0)))
                 (open-binding bindings vars addr)
                 source-alist
                 label-alist
                 object-alist
                 arities)))

    ((<glil-unbind>)
     (values '()
             (close-binding bindings addr)
             source-alist
             label-alist
             object-alist
             arities))

    ((<glil-source> props)
     (values '()
             bindings
             (acons addr props source-alist)
             label-alist
             object-alist
             arities))

    ((<glil-void>)
     (emit-code '((void))))

    ((<glil-const> obj)
     (cond
      ((object->assembly obj)
       => (lambda (code)
            (emit-code (list code))))
      ((not object-alist)
       (emit-code (dump-object obj addr)))
      (else
       (receive (i object-alist)
           (object-index-and-alist obj object-alist)
         (emit-code/object (if (< i 256)
                               `((object-ref ,i))
                               `((long-object-ref ,(quotient i 256)
                                                  ,(modulo i 256))))
                           object-alist)))))

    ((<glil-lexical> local? boxed? op index)
     (emit-code
      (if local?
          (if (< index 256)
              (case op
                ((ref) (if boxed?
                           `((local-boxed-ref ,index))
                           `((local-ref ,index))))
                ((set) (if boxed?
                           `((local-boxed-set ,index))
                           `((local-set ,index))))
                ((box) `((box ,index)))
                ((empty-box) `((empty-box ,index)))
                ((fix) `((fix-closure 0 ,index)))
                ((bound?) (if boxed?
                              `((local-ref ,index)
                                (variable-bound?))
                              `((local-bound? ,index))))
                (else (error "what" op)))
              (let ((a (quotient index 256))
                    (b (modulo index 256)))
                `((,(case op
                      ((ref)
                       (if boxed?
                           `((long-local-ref ,a ,b)
                             (variable-ref))
                           `((long-local-ref ,a ,b))))
                      ((set)
                       (if boxed?
                           `((long-local-ref ,a ,b)
                             (variable-set))
                           `((long-local-set ,a ,b))))
                      ((box)
                       `((make-variable)
                         (variable-set)
                         (long-local-set ,a ,b)))
                      ((empty-box)
                       `((make-variable)
                         (long-local-set ,a ,b)))
                      ((fix)
                       `((fix-closure ,a ,b)))
                      ((bound?)
                       (if boxed?
                           `((long-local-ref ,a ,b)
                             (variable-bound?))
                           `((long-local-bound? ,a ,b))))
                      (else (error "what" op)))
                   ,index))))
          `((,(case op
                ((ref) (if boxed? 'free-boxed-ref 'free-ref))
                ((set) (if boxed? 'free-boxed-set (error "what." glil)))
                (else (error "what" op)))
             ,index)))))

    ((<glil-toplevel> op name)
     (case op
       ((ref set)
        (cond
         ((not object-alist)
          (emit-code `(,@(dump-object name addr)
                       (link-now)
                       ,(case op
                          ((ref) '(variable-ref))
                          ((set) '(variable-set))))))
         (else
          (receive (i object-alist)
              (object-index-and-alist (make-variable-cache-cell name)
                                      object-alist)
            (emit-code/object (if (< i 256)
                                  `((,(case op
                                        ((ref) 'toplevel-ref)
                                        ((set) 'toplevel-set))
                                     ,i))
                                  `((,(case op
                                        ((ref) 'long-toplevel-ref)
                                        ((set) 'long-toplevel-set))
                                     ,(quotient i 256)
                                     ,(modulo i 256))))
                              object-alist)))))
       ((define)
        (emit-code `(,@(dump-object name addr)
                     (define))))
       (else
        (error "unknown toplevel var kind" op name))))

    ((<glil-module> op mod name public?)
     (let ((key (list mod name public?)))
       (case op
         ((ref set)
          (cond
           ((not object-alist)
            (emit-code `(,@(dump-object key addr)
                         (link-now)
                         ,(case op
                            ((ref) '(variable-ref))
                            ((set) '(variable-set))))))
           (else
            (receive (i object-alist)
                (object-index-and-alist (make-variable-cache-cell key)
                                        object-alist)
              (emit-code/object (case op
                                  ((ref) `((toplevel-ref ,i)))
                                  ((set) `((toplevel-set ,i))))
                                object-alist)))))
         (else
          (error "unknown module var kind" op key)))))

    ((<glil-label> label)
     (let ((code (align-block addr)))
       (values code
               bindings
               source-alist
               (acons label (addr+ addr code) label-alist)
               object-alist
               arities)))

    ((<glil-branch> inst label)
     (emit-code `((,inst ,label))))

    ;; nargs is number of stack args to insn. probably should rename.
    ((<glil-call> inst nargs)
     (if (not (instruction? inst))
         (error "Unknown instruction:" inst))
     (let ((pops (instruction-pops inst)))
       (cond ((< pops 0)
              (case (instruction-length inst)
                ((1) (emit-code `((,inst ,nargs))))
                ((2) (emit-code `((,inst ,(quotient nargs 256)
                                         ,(modulo nargs 256)))))
                (else (error "Unknown length for variable-arg instruction:"
                             inst (instruction-length inst)))))
             ((= pops nargs)
              (emit-code `((,inst))))
             (else
              (error "Wrong number of stack arguments to instruction:" inst nargs)))))

    ((<glil-mv-call> nargs ra)
     (emit-code `((mv-call ,nargs ,ra))))

    ((<glil-prompt> label escape-only?)
     (emit-code `((prompt ,(if escape-only? 1 0) ,label))))))

(define (dump-object x addr)
  (define (too-long x)
    (error (string-append x " too long")))

  (cond
   ((object->assembly x) => list)
   ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
   ((subprogram? x)
    (let ((table-code (dump-object (subprogram-table x) addr)))
      `(,@table-code
        ,@(align-program (subprogram-prog x)
                         (addr+ addr table-code)))))
   ((number? x)
    `((load-number ,(number->string x))))
   ((string? x)
    (case (string-bytes-per-char x)
      ((1) `((load-string ,x)))
      ((4) (align-code `(load-wide-string ,x) addr 4 4))
      (else (error "bad string bytes per char" x))))
   ((symbol? x)
    (let ((str (symbol->string x)))
      (case (string-bytes-per-char str)
        ((1) `((load-symbol ,str)))
        ((4) `(,@(dump-object str addr)
               (make-symbol)))
        (else (error "bad string bytes per char" str)))))
   ((keyword? x)
    `(,@(dump-object (keyword->symbol x) addr)
      (make-keyword)))
   ((list? x)
    (let ((tail (let ((len (length x)))
                  (if (>= len 65536) (too-long "list"))
                  `((list ,(quotient len 256) ,(modulo len 256))))))
      (let dump-objects ((objects x) (codes '()) (addr addr))
        (if (null? objects)
            (fold append tail codes)
            (let ((code (dump-object (car objects) addr)))
              (dump-objects (cdr objects) (cons code codes)
                            (addr+ addr code)))))))
   ((pair? x)
    (let ((kar (dump-object (car x) addr)))
      `(,@kar
        ,@(dump-object (cdr x) (addr+ addr kar))
        (cons))))
   ((and (vector? x)
         (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
    (let* ((len (vector-length x))
           (tail (if (>= len 65536)
                     (too-long "vector")
                     `((vector ,(quotient len 256) ,(modulo len 256))))))
      (let dump-objects ((i 0) (codes '()) (addr addr))
        (if (>= i len)
            (fold append tail codes)
            (let ((code (dump-object (vector-ref x i) addr)))
              (dump-objects (1+ i) (cons code codes)
                            (addr+ addr code)))))))
   ((and (array? x) (symbol? (array-type x)))
    (let* ((type (dump-object (array-type x) addr))
           (shape (dump-object (array-shape x) (addr+ addr type))))
      `(,@type
        ,@shape
        ,@(align-code
           `(load-array ,(uniform-array->bytevector x))
           (addr+ (addr+ addr type) shape)
           8
           4))))
   ((array? x)
    ;; an array of generic scheme values
    (let* ((contents (array-contents x))
           (len (vector-length contents)))
      (let dump-objects ((i 0) (codes '()) (addr addr))
        (if (< i len)
            (let ((code (dump-object (vector-ref contents i) addr)))
              (dump-objects (1+ i) (cons code codes)
                            (addr+ addr code)))
            (fold append
                  `(,@(dump-object (array-shape x) addr)
                    (make-array ,(quotient (ash len -16) 256)
                                ,(logand #xff (ash len -8))
                                ,(logand #xff len)))
                  codes)))))
   (else
    (error "assemble: unrecognized object" x))))


code:
;;; Guile VM code converters

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language glil decompile-assembly)
  #:use-module (system base pmatch)
  #:use-module (system vm program)
  #:use-module (language assembly)
  #:use-module (language glil)
  #:export (decompile-assembly))

(define (decompile-assembly x env opts)
  (values (decompile-toplevel x)
          env))

(define (decompile-toplevel x)
  (pmatch x
    ((load-program ,labels ,len ,meta . ,body)
     (decompile-load-program (decompile-meta meta)
                             body labels #f))
    (else
     (error "invalid assembly" x))))

(define (decompile-meta meta)
  (and meta
      (let ((prog (decompile-toplevel meta)))
        (if (and (glil-program? prog)
                 (= (length (glil-program-body prog)) 2)
                 (glil-const? (car (glil-program-body prog))))
            (glil-const-obj (car (glil-program-body prog)))
            (error "metadata not a thunk returning a const" prog)))))

(define *placeholder* (list 'placeholder))

(define (emit-constants l out)
  (let lp ((in (reverse l)) (out out))
    (cond ((null? in) out)
          ((eq? (car in) *placeholder*) (lp (cdr in) out))
          ((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
          (else (lp (cdr in) (cons (make-glil-const (car l)) out))))))

(define (decompile-load-program meta body labels
                                objects)
  (let ((glil-labels (sort (map (lambda (x)
                                  (cons (cdr x) (make-glil-label (car x))))
                                labels)
                           (lambda (x y) (< (car x) (car y)))))
        (bindings (sort (if meta (car meta) '())
                        (lambda (x y) (< (binding:start x) (binding:start y)))))
        (unbindings (sort (if meta (car meta) '())
                          (lambda (x y) (< (binding:end x) (binding:end y)))))
        (sources (if meta (cadr meta) '()))
        (filename #f)
        (props (if meta (cddr meta) '())))
    (define (pop-bindings! addr)
      (let lp ((in bindings) (out '()))
        (if (or (null? in) (> (binding:start (car in)) addr))
            (begin
              (set! bindings in)
              (if (null? out) #f (reverse out)))
            (lp (cdr in) (cons (car in) out)))))
    (define (pop-unbindings! addr)
      (let lp ((in unbindings) (out '()))
        (if (or (null? in) (> (binding:end (car in)) addr))
            (begin
              (set! unbindings in)
              (if (null? out) #f (reverse out)))
            (lp (cdr in) (cons (car in) out)))))
    (define (pop-source! addr)
      ;; a fragile algorithm.
      (cond ((null? sources) #f)
            ((eq? (caar sources) 'filename)
             (set! filename (cdar sources))
             (pop-source! addr))
            ((eqv? (caar sources) addr)
             (let ((x (car sources)))
               (set! sources (cdr sources))
               `((filename . ,filename)
                 (line . ,(cadr x))
                 (column . ,(cddr x)))))
            (else #f)))
    (let lp ((in body) (stack '()) (out '()) (pos 0))
      (cond
       ((null? in)
        (or (null? stack) (error "leftover stack insts" stack body))
        (make-glil-program props (reverse out)))
       ((pop-bindings! pos)
        => (lambda (bindings)
             (lp in stack
                 (cons (make-glil-bind bindings)
                       out)
                 pos)))
       ((pop-unbindings! pos)
        => (lambda (bindings)
             (lp in stack (cons (make-glil-unbind) out) pos)))
       ((pop-source! pos)
        => (lambda (s)
             (lp in stack (cons (make-glil-source s) out) pos)))
       ((and (or (null? out) (not (glil-label? (car out))))
             (assv-ref glil-labels pos))
        => (lambda (label)
             (lp in stack (cons label out) pos)))
       (else
        (pmatch (car in)
          ((nop)
           (lp (cdr in) stack out (1+ pos)))
          ((make-false)
           (lp (cdr in) (cons #f stack) out (1+ pos)))
          ((make-nil)
           (lp (cdr in) (cons #nil stack) out (1+ pos)))
          ((load-program ,labels ,sublen ,meta . ,body)
           (lp (cdr in)
               (cons (decompile-load-program (decompile-meta meta)
                                             body labels (car stack))
                     (cdr stack))
               out
               (+ pos (byte-length (car in)))))
          ((load-symbol ,str)
           (lp (cdr in) (cons (string->symbol str) stack) out
               (+ pos 1 (string-length str))))
          ((make-int8:0)
           (lp (cdr in) (cons 0 stack) out (1+ pos)))
          ((make-int8:1)
           (lp (cdr in) (cons 1 stack) out (1+ pos)))
          ((make-int8 ,n)
           (lp (cdr in) (cons n stack) out (+ pos 2)))
          ((cons)
           (let ((head (list-head stack 2))
                 (stack (list-tail stack 2)))
             (if (memq *placeholder* head)
                 (lp (cdr in) (cons *placeholder* stack)
                     (cons (make-glil-call 'cons 2) (emit-constants head out))
                     (+ pos 1))
                 (lp (cdr in) (cons (cons (cadr head) (car head)) stack)
                     out (+ pos 3)))))
          ((list ,a ,b)
           (let* ((len (+ (ash a 8) b))
                  (head (list-head stack len))
                  (stack (list-tail stack len)))
             (if (memq *placeholder* head)
                 (lp (cdr in) (cons *placeholder* stack)
                     (cons (make-glil-call 'list len) (emit-constants head out))
                     (+ pos 3))
                 (lp (cdr in) (cons (reverse head) stack) out (+ pos 3)))))
          ((make-eol)
           (lp (cdr in) (cons '() stack) out (1+ pos)))
          ((return)
           (lp (cdr in) (cdr stack)
               (cons (make-glil-call 'return 1)
                     (emit-constants (list-head stack 1) out))
               (1+ pos)))
          ((local-ref ,n)
           (lp (cdr in) (cons *placeholder* stack)
               (cons (make-glil-local 'ref n)
                     out) (+ pos 2)))
          ((local-set ,n)
           (lp (cdr in) (cdr stack)
               (cons (make-glil-local 'set n)
                     (emit-constants (list-head stack 1) out))
               (+ pos 2)))
          ((br-if-not ,l)
           (lp (cdr in) (cdr stack)
               (cons (make-glil-branch 'br-if-not l) out)
               (+ pos 3)))
          ((mul)
           (lp (cdr in) (cons *placeholder* (cddr stack))
               (cons (make-glil-call 'mul 2)
                     (emit-constants (list-head stack 2) out))
               (+ pos 1)))
          ((tail-call ,n)
           (lp (cdr in) (list-tail stack (1+ n))
               (cons (make-glil-call 'tail-call n)
                     (emit-constants (list-head stack (1+ n)) out))
               (+ pos 2)))
          (else (error "unsupported decompilation" (car in)))))))))


code:
;;; Guile Lowlevel Intermediate Language

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language glil spec)
  #:use-module (system base language)
  #:use-module (language glil)
  #:use-module (language glil compile-assembly)
  #:use-module (language glil decompile-assembly)
  #:export (glil))

(define (write-glil exp . port)
  (apply write (unparse-glil exp) port))

(define (compile-asm x e opts)
  (values (compile-assembly x) e e))

(define-language glil
  #:title	"Guile Lowlevel Intermediate Language (GLIL)"
  #:reader	(lambda (port env) (read port))
  #:printer	write-glil
  #:parser      parse-glil
  #:compilers   `((assembly . ,compile-asm))
  #:decompilers `((assembly . ,decompile-assembly)))


code:
;;; Guile Virtual Machine Object Code

;; Copyright (C) 2001 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language objcode)
  #:export (encode-length decode-length))

;;;
;;; Variable-length interface
;;;

;; NOTE: decoded in vm_fetch_length in vm.c as well.

(define (encode-length len)
  (cond ((< len 254) (u8vector len))
	((< len (* 256 256))
	 (u8vector 254 (quotient len 256) (modulo len 256)))
	((< len most-positive-fixnum)
	 (u8vector 255
		   (quotient len (* 256 256 256))
		   (modulo (quotient len (* 256 256)) 256)
		   (modulo (quotient len 256) 256)
		   (modulo len 256)))
	(else (error "Too long code length:" len))))

(define (decode-length pop)
  (let ((x (pop)))
    (cond ((< x 254) x)
	  ((= x 254) (+ (ash x 8) (pop)))
	  (else
           (let* ((b2 (pop))
                  (b3 (pop))
                  (b4 (pop)))
             (+ (ash x 24) (ash b2 16) (ash b3 8) b4))))))


code:
;;; Guile Lowlevel Intermediate Language

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language objcode spec)
  #:use-module (system base language)
  #:use-module (system vm objcode)
  #:use-module (system vm program)
  #:export (objcode))

(define (objcode->value x e opts)
  (let ((thunk (make-program x #f #f)))
    (if (eq? e (current-module))
        ;; save a cons in this case
        (values (thunk) e e)
        (save-module-excursion
         (lambda ()
           (set-current-module e)
           (values (thunk) e e))))))

;; since locals are allocated on the stack and can have limited scope,
;; in many cases we use one local for more than one lexical variable. so
;; the returned locals set is a list, where element N of the list is
;; itself a list of bindings for local variable N.
(define (collapse-locals locs)
  (let lp ((ret '()) (locs locs))
    (if (null? locs)
        (map cdr (sort! ret
                        (lambda (x y) (< (car x) (car y)))))
        (let ((b (car locs)))
          (cond
           ((assv-ref ret (binding:index b))
            => (lambda (bindings)
                 (append! bindings (list b))
                 (lp ret (cdr locs))))
           (else
            (lp (acons (binding:index b) (list b) ret)
                (cdr locs))))))))

(define (decompile-value x env opts)
  (cond
   ((program? x)
    (let ((objs  (program-objects x))
          (meta  (program-meta x))
          (free-vars  (program-free-variables x))
          (binds (program-bindings x))
          (srcs  (program-sources x)))
      (let ((blocs (and binds (collapse-locals binds))))
        (values (program-objcode x)
                `((objects . ,objs)
                  (meta    . ,(and meta (meta)))
                  (free-vars . ,free-vars)
                  (blocs   . ,blocs)
                  (sources . ,srcs))))))
   ((objcode? x)
    (values x #f))
   (else
    (error "can't decompile ~A: not a program or objcode" x))))

(define-language objcode
  #:title	"Guile Object Code"
  #:reader	#f
  #:printer	write-objcode
  #:compilers   `((value . ,objcode->value))
  #:decompilers `((value . ,decompile-value))
  )


code:
;;; Guile Scheme specification

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language scheme compile-tree-il)
  #:use-module (language tree-il)
  #:export (compile-tree-il))

;;; environment := MODULE

(define (compile-tree-il x e opts)
  (save-module-excursion
   (lambda ()
     (set-current-module e)
     (let* ((x (macroexpand x 'c '(compile load eval)))
            (cenv (current-module)))
       (values x cenv cenv)))))


code:
;;; Guile VM code converters

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language scheme decompile-tree-il)
  #:use-module (language tree-il)
  #:export (decompile-tree-il))

(define (decompile-tree-il x env opts)
  (values (tree-il->scheme x) env))


code:
;;; Guile Scheme specification

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

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language scheme spec)
  #:use-module (system base compile)
  #:use-module (system base language)
  #:use-module (language scheme compile-tree-il)
  #:use-module (language scheme decompile-tree-il)
  #:export (scheme))

;;;
;;; Reader
;;;

(read-enable 'positions)

;;;
;;; Language definition
;;;

(define-language scheme
  #:title	"Scheme"
  #:reader      (lambda (port env)
                  ;; Use the binding of current-reader from the environment.
                  ;; FIXME: Handle `read-options' as well?
                  ((or (and=> (and=> (module-variable env 'current-reader)
                                     variable-ref)
                              fluid-ref)
                       read)
                   port))

  #:compilers   `((tree-il . ,compile-tree-il))
  #:decompilers `((tree-il . ,decompile-tree-il))
  #:evaluator	(lambda (x module) (primitive-eval x))
  #:printer	write
  #:make-default-environment
                (lambda ()
                  ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
                  ;; `fluid-set!', etc. don't have any effect in the current environment.
                  (let ((m (make-fresh-user-module)))
                    ;; Provide a separate `current-reader' fluid so that
                    ;; compile-time changes to `current-reader' are
                    ;; limited to the current compilation unit.
                    (module-define! m 'current-reader (make-fluid))
                    m)))


code:
;;;; 	Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (language tree-il)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (system base pmatch)
  #:use-module (system base syntax)
  #:export (tree-il-src

            <void> void? make-void void-src
            <const> const? make-const const-src const-exp
            <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
            <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
            <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
            <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
            <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
            <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
            <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
            <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
            <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
            <application> application? make-application application-src application-proc application-args
            <sequence> sequence? make-sequence sequence-src sequence-exps
            <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
            <lambda-case> lambda-case? make-lambda-case lambda-case-src
                          lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
                          lambda-case-inits lambda-case-gensyms
                          lambda-case-body lambda-case-alternate
            <let> let? make-let let-src let-names let-gensyms let-vals let-body
            <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
            <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
            <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
            <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
            <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
            <dynref> dynref? make-dynref dynref-src dynref-fluid
            <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
            <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
            <abort> abort? make-abort abort-src abort-tag abort-args abort-tail

            parse-tree-il
            unparse-tree-il
            tree-il->scheme

            tree-il-fold
            make-tree-il-folder
            post-order!
            pre-order!))

(define (print-tree-il exp port)
  (format port "#<tree-il ~a>" (unparse-tree-il exp)))

(define-syntax borrow-core-vtables
  (lambda (x)
    (syntax-case x ()
      ((_)
       (let lp ((n 0) (out '()))
         (if (< n (vector-length %expanded-vtables))
             (lp (1+ n)
                 (let* ((vtable (vector-ref %expanded-vtables n))
                        (stem (struct-ref vtable (+ vtable-offset-user 0)))
                        (fields (struct-ref vtable (+ vtable-offset-user 2)))
                        (sfields (map
                                  (lambda (f) (datum->syntax x f))
                                  fields))
                        (type (datum->syntax x (symbol-append '< stem '>)))
                        (ctor (datum->syntax x (symbol-append 'make- stem)))
                        (pred (datum->syntax x (symbol-append stem '?))))
                   (let lp ((n 0) (fields fields)
                            (out (cons*
                                  #`(define (#,ctor #,@sfields)
                                      (make-struct #,type 0 #,@sfields))
                                  #`(define (#,pred x)
                                      (and (struct? x)
                                           (eq? (struct-vtable x) #,type)))
                                  #`(struct-set! #,type vtable-index-printer
                                                 print-tree-il)
                                  #`(define #,type
                                           (vector-ref %expanded-vtables #,n))
                                       out)))
                     (if (null? fields)
                         out
                         (lp (1+ n)
                             (cdr fields)
                             (let ((acc (datum->syntax
                                         x (symbol-append stem '- (car fields)))))
                               (cons #`(define #,acc
                                         (make-procedure-with-setter
                                          (lambda (x) (struct-ref x #,n))
                                          (lambda (x v) (struct-set! x #,n v))))
                                     out)))))))
             #`(begin #,@(reverse out))))))))

(borrow-core-vtables)

  ;; (<void>)
  ;; (<const> exp)
  ;; (<primitive-ref> name)
  ;; (<lexical-ref> name gensym)
  ;; (<lexical-set> name gensym exp)
  ;; (<module-ref> mod name public?)
  ;; (<module-set> mod name public? exp)
  ;; (<toplevel-ref> name)
  ;; (<toplevel-set> name exp)
  ;; (<toplevel-define> name exp)
  ;; (<conditional> test consequent alternate)
  ;; (<application> proc args)
  ;; (<sequence> exps)
  ;; (<lambda> meta body)
  ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
  ;; (<let> names gensyms vals body)
  ;; (<letrec> in-order? names gensyms vals body)
  ;; (<dynlet> fluids vals body)

(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
  (<fix> names gensyms vals body)
  (<let-values> exp body)
  (<dynwind> winder body unwinder)
  (<dynref> fluid)
  (<dynset> fluid exp)
  (<prompt> tag body handler)
  (<abort> tag args tail))

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

(define (parse-tree-il exp)
  (let ((loc (location exp))
        (retrans (lambda (x) (parse-tree-il x))))
    (pmatch exp
     ((void)
      (make-void loc))

     ((apply ,proc . ,args)
      (make-application loc (retrans proc) (map retrans args)))

     ((if ,test ,consequent ,alternate)
      (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))

     ((primitive ,name) (guard (symbol? name))
      (make-primitive-ref loc name))

     ((lexical ,name) (guard (symbol? name))
      (make-lexical-ref loc name name))

     ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
      (make-lexical-ref loc name sym))

     ((set! (lexical ,name) ,exp) (guard (symbol? name))
      (make-lexical-set loc name name (retrans exp)))

     ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
      (make-lexical-set loc name sym (retrans exp)))

     ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
      (make-module-ref loc mod name #t))

     ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
      (make-module-set loc mod name #t (retrans exp)))

     ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
      (make-module-ref loc mod name #f))

     ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
      (make-module-set loc mod name #f (retrans exp)))

     ((toplevel ,name) (guard (symbol? name))
      (make-toplevel-ref loc name))

     ((set! (toplevel ,name) ,exp) (guard (symbol? name))
      (make-toplevel-set loc name (retrans exp)))

     ((define ,name ,exp) (guard (symbol? name))
      (make-toplevel-define loc name (retrans exp)))

     ((lambda ,meta ,body)
      (make-lambda loc meta (retrans body)))

     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
      (make-lambda-case loc req opt rest kw
                        (map retrans inits) gensyms
                        (retrans body)
                        (and=> alternate retrans)))

     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body))
      (make-lambda-case loc req opt rest kw
                        (map retrans inits) gensyms
                        (retrans body)
                        #f))

     ((const ,exp)
      (make-const loc exp))

     ((begin . ,exps)
      (make-sequence loc (map retrans exps)))

     ((let ,names ,gensyms ,vals ,body)
      (make-let loc names gensyms (map retrans vals) (retrans body)))

     ((letrec ,names ,gensyms ,vals ,body)
      (make-letrec loc #f names gensyms (map retrans vals) (retrans body)))

     ((letrec* ,names ,gensyms ,vals ,body)
      (make-letrec loc #t names gensyms (map retrans vals) (retrans body)))

     ((fix ,names ,gensyms ,vals ,body)
      (make-fix loc names gensyms (map retrans vals) (retrans body)))

     ((let-values ,exp ,body)
      (make-let-values loc (retrans exp) (retrans body)))

     ((dynwind ,winder ,body ,unwinder)
      (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))

     ((dynlet ,fluids ,vals ,body)
      (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))

     ((dynref ,fluid)
      (make-dynref loc (retrans fluid)))

     ((dynset ,fluid ,exp)
      (make-dynset loc (retrans fluid) (retrans exp)))

     ((prompt ,tag ,body ,handler)
      (make-prompt loc (retrans tag) (retrans body) (retrans handler)))

     ((abort ,tag ,args ,tail)
      (make-abort loc (retrans tag) (map retrans args) (retrans tail)))

     (else
      (error "unrecognized tree-il" exp)))))

(define (unparse-tree-il tree-il)
  (record-case tree-il
    ((<void>)
     '(void))

    ((<application> proc args)
     `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))

    ((<conditional> test consequent alternate)
     `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))

    ((<primitive-ref> name)
     `(primitive ,name))

    ((<lexical-ref> name gensym)
     `(lexical ,name ,gensym))

    ((<lexical-set> name gensym exp)
     `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))

    ((<module-ref> mod name public?)
     `(,(if public? '@ '@@) ,mod ,name))

    ((<module-set> mod name public? exp)
     `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))

    ((<toplevel-ref> name)
     `(toplevel ,name))

    ((<toplevel-set> name exp)
     `(set! (toplevel ,name) ,(unparse-tree-il exp)))

    ((<toplevel-define> name exp)
     `(define ,name ,(unparse-tree-il exp)))

    ((<lambda> meta body)
     `(lambda ,meta ,(unparse-tree-il body)))

    ((<lambda-case> req opt rest kw inits gensyms body alternate)
     `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
                    ,(unparse-tree-il body))
                   . ,(if alternate (list (unparse-tree-il alternate)) '())))

    ((<const> exp)
     `(const ,exp))

    ((<sequence> exps)
     `(begin ,@(map unparse-tree-il exps)))

    ((<let> names gensyms vals body)
     `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))

    ((<letrec> in-order? names gensyms vals body)
     `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
       ,(map unparse-tree-il vals) ,(unparse-tree-il body)))

    ((<fix> names gensyms vals body)
     `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))

    ((<let-values> exp body)
     `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))

    ((<dynwind> body winder unwinder)
     `(dynwind ,(unparse-tree-il body)
               ,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))

    ((<dynlet> fluids vals body)
     `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
              ,(unparse-tree-il body)))

    ((<dynref> fluid)
     `(dynref ,(unparse-tree-il fluid)))

    ((<dynset> fluid exp)
     `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))

    ((<prompt> tag body handler)
     `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))

    ((<abort> tag args tail)
     `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
             ,(unparse-tree-il tail)))))

(define (tree-il->scheme e)
  (record-case e
    ((<void>)
     '(if #f #f))

    ((<application> proc args)
     `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))

    ((<conditional> test consequent alternate)
     (if (void? alternate)
         `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent))
         `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent) ,(tree-il->scheme alternate))))

    ((<primitive-ref> name)
     name)

    ((<lexical-ref> gensym)
     gensym)

    ((<lexical-set> gensym exp)
     `(set! ,gensym ,(tree-il->scheme exp)))

    ((<module-ref> mod name public?)
     `(,(if public? '@ '@@) ,mod ,name))

    ((<module-set> mod name public? exp)
     `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))

    ((<toplevel-ref> name)
     name)

    ((<toplevel-set> name exp)
     `(set! ,name ,(tree-il->scheme exp)))

    ((<toplevel-define> name exp)
     `(define ,name ,(tree-il->scheme exp)))

    ((<lambda> meta body)
     ;; fixme: put in docstring
     (tree-il->scheme body))

    ((<lambda-case> req opt rest kw inits gensyms body alternate)
     (cond
      ((and (not opt) (not kw) (not alternate))
       `(lambda ,(if rest (apply cons* gensyms) gensyms)
          ,(tree-il->scheme body)))
      ((and (not opt) (not kw))
       (let ((alt-expansion (tree-il->scheme alternate))
             (formals (if rest (apply cons* gensyms) gensyms)))
         (case (car alt-expansion)
           ((lambda)
            `(case-lambda (,formals ,(tree-il->scheme body))
                          ,@(cdr alt-expansion)))
           ((lambda*)
            `(case-lambda* (,formals ,(tree-il->scheme body))
                           ,(cdr alt-expansion)))
           ((case-lambda)
            `(case-lambda (,formals ,(tree-il->scheme body))
                          ,@(cdr alt-expansion)))
           ((case-lambda*)
            `(case-lambda* (,formals ,(tree-il->scheme body))
                           ,@(cdr alt-expansion))))))
      (else
       (let* ((alt-expansion (and alternate (tree-il->scheme alternate)))
              (nreq (length req))
              (nopt (if opt (length opt) 0))
              (restargs (if rest (list-ref gensyms (+ nreq nopt)) '()))
              (reqargs (list-head gensyms nreq))
              (optargs (if opt
                           `(#:optional
                             ,@(map list
                                    (list-head (list-tail gensyms nreq) nopt)
                                    (map tree-il->scheme
                                         (list-head inits nopt))))
                           '()))
              (kwargs (if kw
                          `(#:key
                            ,@(map list
                                   (map caddr (cdr kw))
                                   (map tree-il->scheme
                                        (list-tail inits nopt))
                                   (map car (cdr kw)))
                            ,@(if (car kw)
                                  '(#:allow-other-keys)
                                  '()))
                          '()))
              (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
         (if (not alt-expansion)
             `(lambda* ,formals ,(tree-il->scheme body))
             (case (car alt-expansion)
               ((lambda lambda*)
                `(case-lambda* (,formals ,(tree-il->scheme body))
                               ,(cdr alt-expansion)))
               ((case-lambda case-lambda*)
                `(case-lambda* (,formals ,(tree-il->scheme body))
                               ,@(cdr alt-expansion)))))))))

    ((<const> exp)
     (if (and (self-evaluating? exp) (not (vector? exp)))
         exp
         (list 'quote exp)))

    ((<sequence> exps)
     `(begin ,@(map tree-il->scheme exps)))

    ((<let> gensyms vals body)
     `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))

    ((<letrec> in-order? gensyms vals body)
     `(,(if in-order? 'letrec* 'letrec)
       ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))

    ((<fix> gensyms vals body)
     ;; not a typo, we really do translate back to letrec. use letrec* since it
     ;; doesn't matter, and the naive letrec* transformation does not require an
     ;; inner let.
     `(letrec* ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))

    ((<let-values> exp body)
     `(call-with-values (lambda () ,(tree-il->scheme exp))
        ,(tree-il->scheme (make-lambda #f '() body))))

    ((<dynwind> body winder unwinder)
     `(dynamic-wind ,(tree-il->scheme winder)
                    (lambda () ,(tree-il->scheme body))
                    ,(tree-il->scheme unwinder)))

    ((<dynlet> fluids vals body)
     `(with-fluids ,(map list
                         (map tree-il->scheme fluids)
                         (map tree-il->scheme vals))
        ,(tree-il->scheme body)))

    ((<dynref> fluid)
     `(fluid-ref ,(tree-il->scheme fluid)))

    ((<dynset> fluid exp)
     `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp)))

    ((<prompt> tag body handler)
     `((@ (ice-9 control) prompt)
       ,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body))
       ,(tree-il->scheme handler)))

    ((<abort> tag args tail)
     `(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)
             ,(tree-il->scheme tail)))))

(define (tree-il-fold leaf down up seed tree)
  "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
into a sub-tree, and UP when leaving a sub-tree.  Each of these procedures is
invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
and SEED is the current result, intially seeded with SEED.

This is an implementation of `foldts' as described by Andy Wingo in
``Applications of fold to XML transformation''."
  (let loop ((tree   tree)
             (result seed))
    (if (or (null? tree) (pair? tree))
        (fold loop result tree)
        (record-case tree
          ((<lexical-set> exp)
           (up tree (loop exp (down tree result))))
          ((<module-set> exp)
           (up tree (loop exp (down tree result))))
          ((<toplevel-set> exp)
           (up tree (loop exp (down tree result))))
          ((<toplevel-define> exp)
           (up tree (loop exp (down tree result))))
          ((<conditional> test consequent alternate)
           (up tree (loop alternate
                          (loop consequent
                                (loop test (down tree result))))))
          ((<application> proc args)
           (up tree (loop (cons proc args) (down tree result))))
          ((<sequence> exps)
           (up tree (loop exps (down tree result))))
          ((<lambda> body)
           (up tree (loop body (down tree result))))
          ((<lambda-case> inits body alternate)
           (up tree (if alternate
                        (loop alternate
                              (loop body (loop inits (down tree result))))
                        (loop body (loop inits (down tree result))))))
          ((<let> vals body)
           (up tree (loop body
                          (loop vals
                                (down tree result)))))
          ((<letrec> vals body)
           (up tree (loop body
                          (loop vals
                                (down tree result)))))
          ((<fix> vals body)
           (up tree (loop body
                          (loop vals
                                (down tree result)))))
          ((<let-values> exp body)
           (up tree (loop body (loop exp (down tree result)))))
          ((<dynwind> body winder unwinder)
           (up tree (loop unwinder
                          (loop winder
                                (loop body (down tree result))))))
          ((<dynlet> fluids vals body)
           (up tree (loop body
                          (loop vals
                                (loop fluids (down tree result))))))
          ((<dynref> fluid)
           (up tree (loop fluid (down tree result))))
          ((<dynset> fluid exp)
           (up tree (loop exp (loop fluid (down tree result)))))
          ((<prompt> tag body handler)
           (up tree
               (loop tag (loop body (loop handler
                                          (down tree result))))))
          ((<abort> tag args tail)
           (up tree (loop tail (loop args (loop tag (down tree result))))))
          (else
           (leaf tree result))))))

(define-syntax make-tree-il-folder
  (syntax-rules ()
    ((_ seed ...)
     (lambda (tree down up seed ...)
       (define (fold-values proc exps seed ...)
         (if (null? exps)
             (values seed ...)
             (let-values (((seed ...) (proc (car exps) seed ...)))
               (fold-values proc (cdr exps) seed ...))))
       (let foldts ((tree tree) (seed seed) ...)
         (let*-values
             (((seed ...) (down tree seed ...))
              ((seed ...)
               (record-case tree
                 ((<lexical-set> exp)
                  (foldts exp seed ...))
                 ((<module-set> exp)
                  (foldts exp seed ...))
                 ((<toplevel-set> exp)
                  (foldts exp seed ...))
                 ((<toplevel-define> exp)
                  (foldts exp seed ...))
                 ((<conditional> test consequent alternate)
                  (let*-values (((seed ...) (foldts test seed ...))
                                ((seed ...) (foldts consequent seed ...)))
                    (foldts alternate seed ...)))
                 ((<application> proc args)
                  (let-values (((seed ...) (foldts proc seed ...)))
                    (fold-values foldts args seed ...)))
                 ((<sequence> exps)
                  (fold-values foldts exps seed ...))
                 ((<lambda> body)
                  (foldts body seed ...))
                 ((<lambda-case> inits body alternate)
                  (let-values (((seed ...) (fold-values foldts inits seed ...)))
                    (if alternate
                        (let-values (((seed ...) (foldts body seed ...)))
                          (foldts alternate seed ...))
                        (foldts body seed ...))))
                 ((<let> vals body)
                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
                    (foldts body seed ...)))
                 ((<letrec> vals body)
                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
                    (foldts body seed ...)))
                 ((<fix> vals body)
                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
                    (foldts body seed ...)))
                 ((<let-values> exp body)
                  (let*-values (((seed ...) (foldts exp seed ...)))
                    (foldts body seed ...)))
                 ((<dynwind> body winder unwinder)
                  (let*-values (((seed ...) (foldts body seed ...))
                                ((seed ...) (foldts winder seed ...)))
                    (foldts unwinder seed ...)))
                 ((<dynlet> fluids vals body)
                  (let*-values (((seed ...) (fold-values foldts fluids seed ...))
                                ((seed ...) (fold-values foldts vals seed ...)))
                    (foldts body seed ...)))
                 ((<dynref> fluid)
                  (foldts fluid seed ...))
                 ((<dynset> fluid exp)
                  (let*-values (((seed ...) (foldts fluid seed ...)))
                    (foldts exp seed ...)))
                 ((<prompt> tag body handler)
                  (let*-values (((seed ...) (foldts tag seed ...))
                                ((seed ...) (foldts body seed ...)))
                    (foldts handler seed ...)))
                 ((<abort> tag args tail)
                  (let*-values (((seed ...) (foldts tag seed ...))
                                ((seed ...) (fold-values foldts args seed ...)))
                    (foldts tail seed ...)))
                 (else
                  (values seed ...)))))
           (up tree seed ...)))))))

(define (post-order! f x)
  (let lp ((x x))
    (record-case x
      ((<application> proc args)
       (set! (application-proc x) (lp proc))
       (set! (application-args x) (map lp args)))

      ((<conditional> test consequent alternate)
       (set! (conditional-test x) (lp test))
       (set! (conditional-consequent x) (lp consequent))
       (set! (conditional-alternate x) (lp alternate)))

      ((<lexical-set> name gensym exp)
       (set! (lexical-set-exp x) (lp exp)))

      ((<module-set> mod name public? exp)
       (set! (module-set-exp x) (lp exp)))

      ((<toplevel-set> name exp)
       (set! (toplevel-set-exp x) (lp exp)))

      ((<toplevel-define> name exp)
       (set! (toplevel-define-exp x) (lp exp)))

      ((<lambda> body)
       (set! (lambda-body x) (lp body)))

      ((<lambda-case> inits body alternate)
       (set! inits (map lp inits))
       (set! (lambda-case-body x) (lp body))
       (if alternate
           (set! (lambda-case-alternate x) (lp alternate))))

      ((<sequence> exps)
       (set! (sequence-exps x) (map lp exps)))

      ((<let> gensyms vals body)
       (set! (let-vals x) (map lp vals))
       (set! (let-body x) (lp body)))

      ((<letrec> gensyms vals body)
       (set! (letrec-vals x) (map lp vals))
       (set! (letrec-body x) (lp body)))

      ((<fix> gensyms vals body)
       (set! (fix-vals x) (map lp vals))
       (set! (fix-body x) (lp body)))

      ((<let-values> exp body)
       (set! (let-values-exp x) (lp exp))
       (set! (let-values-body x) (lp body)))

      ((<dynwind> body winder unwinder)
       (set! (dynwind-body x) (lp body))
       (set! (dynwind-winder x) (lp winder))
       (set! (dynwind-unwinder x) (lp unwinder)))

      ((<dynlet> fluids vals body)
       (set! (dynlet-fluids x) (map lp fluids))
       (set! (dynlet-vals x) (map lp vals))
       (set! (dynlet-body x) (lp body)))

      ((<dynref> fluid)
       (set! (dynref-fluid x) (lp fluid)))

      ((<dynset> fluid exp)
       (set! (dynset-fluid x) (lp fluid))
       (set! (dynset-exp x) (lp exp)))

      ((<prompt> tag body handler)
       (set! (prompt-tag x) (lp tag))
       (set! (prompt-body x) (lp body))
       (set! (prompt-handler x) (lp handler)))

      ((<abort> tag args tail)
       (set! (abort-tag x) (lp tag))
       (set! (abort-args x) (map lp args))
       (set! (abort-tail x) (lp tail)))

      (else #f))

    (or (f x) x)))

(define (pre-order! f x)
  (let lp ((x x))
    (let ((x (or (f x) x)))
      (record-case x
        ((<application> proc args)
         (set! (application-proc x) (lp proc))
         (set! (application-args x) (map lp args)))

        ((<conditional> test consequent alternate)
         (set! (conditional-test x) (lp test))
         (set! (conditional-consequent x) (lp consequent))
         (set! (conditional-alternate x) (lp alternate)))

        ((<lexical-set> exp)
         (set! (lexical-set-exp x) (lp exp)))

        ((<module-set> exp)
         (set! (module-set-exp x) (lp exp)))

        ((<toplevel-set> exp)
         (set! (toplevel-set-exp x) (lp exp)))

        ((<toplevel-define> exp)
         (set! (toplevel-define-exp x) (lp exp)))

        ((<lambda> body)
         (set! (lambda-body x) (lp body)))

        ((<lambda-case> inits body alternate)
         (set! inits (map lp inits))
         (set! (lambda-case-body x) (lp body))
         (if alternate (set! (lambda-case-alternate x) (lp alternate))))

        ((<sequence> exps)
         (set! (sequence-exps x) (map lp exps)))

        ((<let> vals body)
         (set! (let-vals x) (map lp vals))
         (set! (let-body x) (lp body)))

        ((<letrec> vals body)
         (set! (letrec-vals x) (map lp vals))
         (set! (letrec-body x) (lp body)))

        ((<fix> vals body)
         (set! (fix-vals x) (map lp vals))
         (set! (fix-body x) (lp body)))

        ((<let-values> exp body)
         (set! (let-values-exp x) (lp exp))
         (set! (let-values-body x) (lp body)))

        ((<dynwind> body winder unwinder)
         (set! (dynwind-body x) (lp body))
         (set! (dynwind-winder x) (lp winder))
         (set! (dynwind-unwinder x) (lp unwinder)))

        ((<dynlet> fluids vals body)
         (set! (dynlet-fluids x) (map lp fluids))
         (set! (dynlet-vals x) (map lp vals))
         (set! (dynlet-body x) (lp body)))

        ((<dynref> fluid)
         (set! (dynref-fluid x) (lp fluid)))

        ((<dynset> fluid exp)
         (set! (dynset-fluid x) (lp fluid))
         (set! (dynset-exp x) (lp exp)))

        ((<prompt> tag body handler)
         (set! (prompt-tag x) (lp tag))
         (set! (prompt-body x) (lp body))
         (set! (prompt-handler x) (lp handler)))

        ((<abort> tag args tail)
         (set! (abort-tag x) (lp tag))
         (set! (abort-args x) (map lp args))
         (set! (abort-tail x) (lp tail)))

        (else #f))
      x)))