/* This C file is machine-generated, and is not the actual source. */

const char *jitterlisp_library_string =
  ";;; JitterLisp (let's say -*- Scheme -*- for the purposes of Emacs) -- library.\n"
  "\n"
  ";;; Copyright (C) 2017, 2018, 2019, 2020 Luca Saiu\n"
  ";;; Updated in 2021 by Luca Saiu\n"
  ";;; Written by Luca Saiu\n"
  "\n"
  ";;; This file is part of the JitterLisp language implementation, distributed as\n"
  ";;; an example along with GNU Jitter under the same license.\n"
  "\n"
  ";;; Jitter is free software: you can redistribute it and/or modify\n"
  ";;; it under the terms of the GNU General Public License as published by\n"
  ";;; the Free Software Foundation, either version 3 of the License, or\n"
  ";;; (at your option) any later version.\n"
  "\n"
  ";;; Jitter is distributed in the hope that it will be useful,\n"
  ";;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n"
  ";;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n"
  ";;; GNU General Public License for more details.\n"
  "\n"
  ";;; You should have received a copy of the GNU General Public License\n"
  ";;; along with GNU Jitter.  If not, see <https://www.gnu.org/licenses/>. */\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Force the library to be run at most once.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;;; Fail if the library has been loaded already.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(if (defined?"" 'jitterlisp-library-loaded)\n"
  "    (error '(you are trying to load the library more than once))\n"
  "    #t)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Type checking.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;;; anything?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; A type predicate always returning #t.\n"
  "(define-constant (anything?"" x)\n"
  "  #t)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Arithmetic and number library.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; Parity: even?"" and odd?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (even?"" n)\n"
  "  (zero?"" (remainder n 2)))\n"
  "\n"
  "(define-constant (odd?"" n)\n"
  "  (not (zero?"" (remainder n 2))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; number?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (number?"" n)\n"
  "  (fixnum?"" n)) ;; There is only one number type right now.\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Conses.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; Composed cons selectors.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; I define these early because some composed selectors are used within the\n"
  ";;; implementation of high-level macros.\n"
  "\n"
  ";; Length 2.\n"
  "(define-constant (caar x) (car (car x)))\n"
  "(define-constant (cadr x) (car (cdr x)))\n"
  "(define-constant (cdar x) (cdr (car x)))\n"
  "(define-constant (cddr x) (cdr (cdr x)))\n"
  "\n"
  ";; Length 3.\n"
  "(define-constant (caaar x) (car (caar x)))\n"
  "(define-constant (caadr x) (car (cadr x)))\n"
  "(define-constant (cadar x) (car (cdar x)))\n"
  "(define-constant (caddr x) (car (cddr x)))\n"
  "(define-constant (cdaar x) (cdr (caar x)))\n"
  "(define-constant (cdadr x) (cdr (cadr x)))\n"
  "(define-constant (cddar x) (cdr (cdar x)))\n"
  "(define-constant (cdddr x) (cdr (cddr x)))\n"
  "\n"
  ";; Length 4.\n"
  "(define-constant (caaaar x) (car (caaar x)))\n"
  "(define-constant (caaadr x) (car (caadr x)))\n"
  "(define-constant (caadar x) (car (cadar x)))\n"
  "(define-constant (caaddr x) (car (caddr x)))\n"
  "(define-constant (cadaar x) (car (cdaar x)))\n"
  "(define-constant (cadadr x) (car (cdadr x)))\n"
  "(define-constant (caddar x) (car (cddar x)))\n"
  "(define-constant (cadddr x) (car (cdddr x)))\n"
  "(define-constant (cdaaar x) (cdr (caaar x)))\n"
  "(define-constant (cdaadr x) (cdr (caadr x)))\n"
  "(define-constant (cdadar x) (cdr (cadar x)))\n"
  "(define-constant (cdaddr x) (cdr (caddr x)))\n"
  "(define-constant (cddaar x) (cdr (cdaar x)))\n"
  "(define-constant (cddadr x) (cdr (cdadr x)))\n"
  "(define-constant (cdddar x) (cdr (cddar x)))\n"
  "(define-constant (cddddr x) (cdr (cdddr x)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Composed cons updaters.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";; Length 2.\n"
  "(define-constant (set-caar! c x) (set-car! (car c) x))\n"
  "(define-constant (set-cadr! c x) (set-car! (cdr c) x))\n"
  "(define-constant (set-cdar! c x) (set-cdr! (car c) x))\n"
  "(define-constant (set-cddr! c x) (set-cdr! (cdr c) x))\n"
  "\n"
  ";; Length 3.\n"
  "(define-constant (set-caaar! c x) (set-car! (caar c) x))\n"
  "(define-constant (set-caadr! c x) (set-car! (cadr c) x))\n"
  "(define-constant (set-cadar! c x) (set-car! (cdar c) x))\n"
  "(define-constant (set-caddr! c x) (set-car! (cddr c) x))\n"
  "(define-constant (set-cdaar! c x) (set-cdr! (caar c) x))\n"
  "(define-constant (set-cdadr! c x) (set-cdr! (cadr c) x))\n"
  "(define-constant (set-cddar! c x) (set-cdr! (cdar c) x))\n"
  "(define-constant (set-cdddr! c x) (set-cdr! (cddr c) x))\n"
  "\n"
  ";; Length 4.\n"
  "(define-constant (set-caaaar! c x) (set-car! (caaar c) x))\n"
  "(define-constant (set-caaadr! c x) (set-car! (caadr c) x))\n"
  "(define-constant (set-caadar! c x) (set-car! (cadar c) x))\n"
  "(define-constant (set-caaddr! c x) (set-car! (caddr c) x))\n"
  "(define-constant (set-cadaar! c x) (set-car! (cdaar c) x))\n"
  "(define-constant (set-cadadr! c x) (set-car! (cdadr c) x))\n"
  "(define-constant (set-caddar! c x) (set-car! (cddar c) x))\n"
  "(define-constant (set-cadddr! c x) (set-car! (cdddr c) x))\n"
  "(define-constant (set-cdaaar! c x) (set-cdr! (caaar c) x))\n"
  "(define-constant (set-cdaadr! c x) (set-cdr! (caadr c) x))\n"
  "(define-constant (set-cdadar! c x) (set-cdr! (cadar c) x))\n"
  "(define-constant (set-cdaddr! c x) (set-cdr! (caddr c) x))\n"
  "(define-constant (set-cddaar! c x) (set-cdr! (cdaar c) x))\n"
  "(define-constant (set-cddadr! c x) (set-cdr! (cdadr c) x))\n"
  "(define-constant (set-cdddar! c x) (set-cdr! (cddar c) x))\n"
  "(define-constant (set-cddddr! c x) (set-cdr! (cdddr c) x))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Quasiquoting.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; quasiquote-procedure.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Define temporary list functions of a few different arities.  It is\n"
  ";;; not worth the trouble to define list as a variadic macro without\n"
  ";;; high-level macros or quasiquoting.\n"
  "(define-constant (list0)         ())\n"
  "(define-constant (list1 x)       (cons x ()))\n"
  "(define-constant (list2 x y)     (cons x (cons y ())))\n"
  "(define-constant (list3 x y z)   (cons x (cons y (cons z ()))))\n"
  "(define-constant (list4 x y z t) (cons x (cons y (cons z (cons t ())))))\n"
  "\n"
  "(define-constant (qq-append xs ys)\n"
  "  (if (list?"" xs)\n"
  "      (append-procedure xs ys)\n"
  "      (error '(unquote-splicing argument evaluates to non-list))))\n"
  "\n"
  "(define-constant (qq-atom x)\n"
  "  ;; `',x\n"
  "  (list2 'quote\n"
  "         x))\n"
  "\n"
  "(define-constant (qq-recursive x depth)\n"
  "  (if (cons?"" x)\n"
  "      (qq-recursive-cons (car x) (cdr x) depth)\n"
  "      (qq-atom x)))\n"
  "\n"
  ";;; ~/r6rs.pdf, §11.17 \"Quasiquotation\".\n"
  "\n"
  "(define-constant (qq-recursive-cons x-car x-cdr depth)\n"
  "  (cond ((eq?"" x-car 'quasiquote)\n"
  "         ;;`(list 'quasiquote ,(qq-recursive (car x-cdr) (1+ depth)))\n"
  "         (list3 'list2\n"
  "                ''quasiquote\n"
  "                (qq-recursive (car x-cdr) (1+ depth))))\n"
  "        ((eq?"" x-car 'unquote)\n"
  "         ;; FIXME: decide what to do with (cdr x-cdr).\n"
  "         (if (zero?"" depth)\n"
  "             (car x-cdr)\n"
  "             ;; `(cons 'unquote ,(qq-recursive x-cdr (1- depth)))\n"
  "             (list3 'cons\n"
  "                    ''unquote\n"
  "                    (qq-recursive x-cdr (1- depth)))))\n"
  "        ((eq?"" x-car 'unquote-splicing)\n"
  "         ;; FIXME: decide what to do with (cdr x-cdr).  This case is\n"
  "         ;; probably different from the one above.  Look at R7RS as well.\n"
  "         (if (zero?"" depth)\n"
  "             (begin\n"
  "               ;; There are several possibilities in this case.\n"
  "               ;; FIXME: consider them, including returning (car x-cdr).\n"
  "               (error '(invalid context for unquote-splicing)))\n"
  "             (begin\n"
  "               ;; `(cons 'unquote-splicing ,(qq-recursive x-cdr (1- depth)))\n"
  "               (list3 'cons\n"
  "                      ''unquote-splicing\n"
  "                      (qq-recursive x-cdr (1- depth))))))\n"
  "        (else\n"
  "         ;;`(append-procedure ,(qq-recursive-as-car x-car depth)\n"
  "         ;;                   ,(qq-recursive x-cdr depth))\n"
  "         (list3 'append-procedure ;; no qq-append here: qq-recursive-as-car returns a list.\n"
  "                (qq-recursive-as-car x-car depth)\n"
  "                (qq-recursive x-cdr depth)))))\n"
  "\n"
  ";;; Return an s-expression evaluating to a singleton list containing the\n"
  ";;; given object.\n"
  "(define-constant (qq-sigleton-expression expression)\n"
  "  (list2 'list1\n"
  "         expression))\n"
  "\n"
  ";;; Return an s-expression evaluating to something equivalent to a variadic\n"
  ";;; call to the list function of the given arguments.\n"
  "(define-constant (qq-variadic-list-expression args)\n"
  "  (if (null?"" args)\n"
  "      '()\n"
  "      ;;`(cons ,(car args) ,(qq-variadic-list-expression (cdr args)))))\n"
  "      (list3 'cons\n"
  "             (car args)\n"
  "             (qq-variadic-list-expression (cdr args)))))\n"
  "\n"
  ";;; Same as qq-variadic-list-expression but for a variadic append.\n"
  "(define-constant (qq-variadic-append-expression args)\n"
  "  (if (null?"" args)\n"
  "      '()\n"
  "      ;;`(append ,(car args) ,(qq-variadic-append-expression (cdr args)))))\n"
  "      (list3 'qq-append\n"
  "             (car args)\n"
  "             (qq-variadic-append-expression (cdr args)))))\n"
  "\n"
  ";;; The car of a quasiquoted cons expands to a *list*, to be combined\n"
  ";;; to the expansion of the cdr by appending, not consing.  This allows\n"
  ";;; for simpler handling of unquote-splicing; when not splicing we just\n"
  ";;; generate a singleton list.\n"
  "(define-constant (qq-recursive-as-car x depth)\n"
  "  (if (cons?"" x)\n"
  "      (qq-recursive-cons-as-car (car x) (cdr x) depth)\n"
  "      ;; `(list ,(qq-atom x))\n"
  "      (qq-sigleton-expression (qq-atom x))))\n"
  "\n"
  ";;; Expand a cons which is the car of a bigger quasiquoted s-expression;\n"
  ";;; therefore, expand to a list as qq-recursive-as-car does.\n"
  "(define-constant (qq-recursive-cons-as-car x-car x-cdr depth)\n"
  "  (cond ((eq?"" x-car 'quasiquote)\n"
  "         ;; (qq-sigleton-expression `(cons 'quasiquote ,(qq-recursive x-cdr (1+ depth))))\n"
  "         (qq-sigleton-expression (list3 'cons\n"
  "                                        ''quasiquote\n"
  "                                        (qq-recursive x-cdr (1+ depth)))))\n"
  "        ((eq?"" x-car 'unquote)\n"
  "         (if (zero?"" depth)\n"
  "             (qq-variadic-list-expression x-cdr)\n"
  "             ;; `(list (cons 'unquote ,(qq-recursive x-cdr (1- depth))))\n"
  "             (list2 'list1\n"
  "                    (list3 'cons\n"
  "                           ''unquote\n"
  "                           (qq-recursive x-cdr (1- depth))))))\n"
  "        ((eq?"" x-car 'unquote-splicing)\n"
  "         (if (zero?"" depth)\n"
  "             (qq-variadic-append-expression x-cdr)\n"
  "             ;;`(list (cons 'unquote-splicing ,(qq-recursive x-cdr (1- depth))))\n"
  "             (list2 'list1\n"
  "                    (list3 'cons\n"
  "                           ''unquote-splicing\n"
  "                           (qq-recursive x-cdr (1- depth))))))\n"
  "        (else\n"
  "         ;;`(list (append-procedure ,(qq-recursive-as-car x-car depth)\n"
  "         ;;                         ,(qq-recursive x-cdr depth))))\n"
  "         (list2 'list1\n"
  "                (list3 'append-procedure\n"
  "                       (qq-recursive-as-car x-car depth)\n"
  "                       (qq-recursive x-cdr depth))))))\n"
  "\n"
  ";;; Quasiquoting as a procedure.\n"
  "(define-constant (quasiquote-procedure x)\n"
  "  (qq-recursive x 0))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; quasiquote.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Now we can finally define quasiquote as a (low-level) macro.  It is trivial:\n"
  ";;; low-level-macro-args is bound to all of the arguments of quasiquote , and we\n"
  ";;; want to fail if those arguments are not a singleton list.  If the arguments\n"
  ";;; are a singleton list we just call quasiquote-procedure on their car.\n"
  "(define-constant quasiquote\n"
  "  (low-level-macro\n"
  "    (cond ((null?"" low-level-macro-args)\n"
  "           (error '(quasiquote with zero arguments)))\n"
  "          ((non-cons?"" low-level-macro-args)\n"
  "           (error '(quasiquote arguments not a list)))\n"
  "          ((non-null?"" (cdr low-level-macro-args))\n"
  "           (error '(quasiquote arguments more than one or not a list)))\n"
  "          (else\n"
  "           (quasiquote-procedure (car low-level-macro-args))))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; List library.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; singleton.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (singleton x)\n"
  "  (cons x ()))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; singleton?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (singleton?"" x)\n"
  "  (if (cons?"" x)\n"
  "      (null?"" (cdr x))\n"
  "      #f))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; null-or-singleton?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return non-#f iff the argument is either () or a singleton list.\n"
  ";;; Rationale: this is useful in macros with a single optional argument,\n"
  ";;; for checking that the optional part of the arguments has the correct\n"
  ";;; shape.\n"
  "(define-constant (null-or-singleton?"" x)\n"
  "  (cond ((null?"" x)\n"
  "         #t)\n"
  "        ((cons?"" x)\n"
  "         (null?"" (cdr x)))\n"
  "        (else\n"
  "         #f)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; list?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";; FIXME: a return statement would be nice here.\n"
  "(define-constant (list?""-iterative xs)\n"
  "  (let* ((go-on #t)\n"
  "         (res #t))\n"
  "    (while go-on\n"
  "      (cond ((null?"" xs)\n"
  "             (set! go-on #f))\n"
  "            ((non-cons?"" xs)\n"
  "             (set! res #f)\n"
  "             (set! go-on #f))\n"
  "            (else\n"
  "             (set! xs (cdr xs)))))\n"
  "    res))\n"
  "\n"
  "(define-constant (list?""-tail-recursive xs)\n"
  "  (cond ((null?"" xs)\n"
  "         #t)\n"
  "        ((cons?"" xs)\n"
  "         (list?""-tail-recursive (cdr xs)))\n"
  "        (else\n"
  "         #f)))\n"
  "\n"
  "(define-constant (list?"" xs)\n"
  "  (list?""-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; symbols?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return non-#f iff the argument is a list of symbols, possibly empty.\n"
  "\n"
  "(define-constant (symbols?""-iterative xs)\n"
  "  (let* ((res #t))\n"
  "    (while (non-null?"" xs)\n"
  "      (cond ((non-cons?"" xs)\n"
  "             (set! xs ())\n"
  "             (set! res #f))\n"
  "            ((symbol?"" (car xs))\n"
  "             (set! xs (cdr xs)))\n"
  "            (else\n"
  "             (set! xs ())\n"
  "             (set! res #f))))\n"
  "    res))\n"
  "\n"
  "(define-constant (symbols?""-tail-recursive xs)\n"
  "  (cond ((null?"" xs)\n"
  "         #t)\n"
  "        ((non-cons?"" xs)\n"
  "         #f)\n"
  "        ((symbol?"" (car xs))\n"
  "         (symbols?""-tail-recursive (cdr xs)))\n"
  "        (else\n"
  "         #f)))\n"
  "\n"
  "(define-constant (symbols?"" xs)\n"
  "   (symbols?""-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; replicate.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (replicate-iterative n x)\n"
  "  (let* ((res ()))\n"
  "    (while (> n 0)\n"
  "      (set! res (cons x res))\n"
  "      (set! n (1- n)))\n"
  "    res))\n"
  "\n"
  "(define-constant (replicate-tail-recursive-helper n x acc)\n"
  "  (if (zero?"" n)\n"
  "      acc\n"
  "      (replicate-tail-recursive-helper (1- n) x (cons x acc))))\n"
  "(define-constant (replicate-tail-recursive n x)\n"
  "  (replicate-tail-recursive-helper n x ()))\n"
  "\n"
  "(define-constant (replicate-non-tail-recursive n x)\n"
  "  (if (zero?"" n)\n"
  "      ()\n"
  "      (cons x (replicate-non-tail-recursive (1- n) x))))\n"
  "\n"
  "(define-constant (replicate n x)\n"
  "  (replicate-iterative n x))\n"
  "\n"
  ";; Just an alias.\n"
  "(define-constant (make-list n x)\n"
  "  (replicate n x))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; last-cons.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return the last cons of xs .  Assume, without checking, that xs is a\n"
  ";;; non-empty proper list.\n"
  "\n"
  "(define-constant (last-cons-iterative xs)\n"
  "  (let* ((cdr-xs (cdr xs)))\n"
  "    (while (not (null?"" cdr-xs))\n"
  "      (set! xs cdr-xs)\n"
  "      (set! cdr-xs (cdr xs)))\n"
  "    xs))\n"
  "\n"
  "(define-constant (last-cons-tail-recursive xs)\n"
  "  (if (null?"" (cdr xs))\n"
  "      xs\n"
  "      (last-cons-tail-recursive (cdr xs))))\n"
  "\n"
  "(define-constant (last-cons xs)\n"
  "  (last-cons-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; last.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (last-iterative xs)\n"
  "  (car (last-cons-iterative xs)))\n"
  "\n"
  "(define-constant (last-tail-recursive xs)\n"
  "  (car (last-cons-tail-recursive xs)))\n"
  "\n"
  "(define-constant (last xs)\n"
  "  (last-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; all-but-last-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (all-but-last-reversed-iterative xs)\n"
  "  (if (null?"" xs)\n"
  "      (error '(all-but-last-reversed-iterative: empty argument))\n"
  "      (let* ((res ()))\n"
  "        (while (non-null?"" (cdr xs))\n"
  "          (set! res (cons (car xs) res))\n"
  "          (set! xs (cdr xs)))\n"
  "        res)))\n"
  "\n"
  "(define-constant (all-but-last-reversed-non-empty-tail-recursive-helper xs acc)\n"
  "  (if (null?"" (cdr xs))\n"
  "      acc\n"
  "      (all-but-last-reversed-non-empty-tail-recursive-helper (cdr xs)\n"
  "                                                             (cons (car xs)\n"
  "                                                                   acc))))\n"
  "(define-constant (all-but-last-reversed-tail-recursive xs)\n"
  "  (if (null?"" xs)\n"
  "      (error '(all-but-last-reversed-tail-recursive: empty argument))\n"
  "      (all-but-last-reversed-non-empty-tail-recursive-helper xs ())))\n"
  "\n"
  "(define-constant (all-but-last-reversed xs)\n"
  "  (all-but-last-reversed-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; all-but-last.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (all-but-last-iterative xs)\n"
  "  (reverse!-iterative (all-but-last-reversed-iterative xs)))\n"
  "\n"
  "(define-constant (all-but-last-tail-recursive xs)\n"
  "  (reverse!-tail-recursive (all-but-last-reversed-tail-recursive xs)))\n"
  "\n"
  "(define-constant (all-but-last-non-empty-non-tail-recursive xs)\n"
  "  (if (null?"" (cdr xs))\n"
  "      ()\n"
  "      (cons (car xs)\n"
  "            (all-but-last-non-empty-non-tail-recursive (cdr xs)))))\n"
  "(define-constant (all-but-last-non-tail-recursive xs)\n"
  "  (if (null?"" xs)\n"
  "      (error '(all-but-last-non-tail-recursive: empty argument))\n"
  "      (all-but-last-non-empty-non-tail-recursive xs)))\n"
  "\n"
  "(define-constant (all-but-last xs)\n"
  "  (all-but-last-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; length.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (length-iterative xs)\n"
  "  (let* ((res 0))\n"
  "    (while (non-null?"" xs)\n"
  "      (set! res (1+ res))\n"
  "      (set! xs (cdr xs)))\n"
  "    res))\n"
  "\n"
  "(define-constant (length-non-tail-recursive xs)\n"
  "  (if (null?"" xs)\n"
  "      0\n"
  "      (1+ (length-non-tail-recursive (cdr xs)))))\n"
  "\n"
  "(define-constant (length-tail-recursive-helper xs acc)\n"
  "  (if (null?"" xs)\n"
  "      acc\n"
  "      (length-tail-recursive-helper (cdr xs) (1+ acc))))\n"
  "(define-constant (length-tail-recursive xs)\n"
  "  (length-tail-recursive-helper xs 0))\n"
  "\n"
  "(define-constant (length xs)\n"
  "  (length-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; append-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (append-reversed-iterative xs ys)\n"
  "  (let* ((res ys))\n"
  "    (while (non-null?"" xs)\n"
  "      (set! res (cons (car xs) res))\n"
  "      (set! xs (cdr xs)))\n"
  "    res))\n"
  "\n"
  "(define-constant (append-reversed-tail-recursive xs ys)\n"
  "  (if (null?"" xs)\n"
  "      ys\n"
  "      (append-reversed-tail-recursive (cdr xs)\n"
  "                                      (cons (car xs) ys))))\n"
  "\n"
  "(define-constant (append-reversed xs ys)\n"
  "  (append-reversed-iterative xs ys))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; reverse.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (reverse-iterative xs)\n"
  "  (append-reversed-iterative xs ()))\n"
  "\n"
  ";; This uses append-procedure instead of append-non-tail-recursive .\n"
  "(define-constant (reverse-non-tail-recursive xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (append-procedure (reverse-non-tail-recursive (cdr xs))\n"
  "                        (singleton (car xs)))))\n"
  "\n"
  ";; This uses append-non-tail-recursive instead of append-procedure .\n"
  "(define-constant (reverse-really-non-tail-recursive xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (append-non-tail-recursive (reverse-non-tail-recursive (cdr xs))\n"
  "                                 (singleton (car xs)))))\n"
  "\n"
  "(define-constant (reverse-tail-recursive-helper xs acc)\n"
  "  (if (null?"" xs)\n"
  "      acc\n"
  "      (reverse-tail-recursive-helper (cdr xs)\n"
  "                                     (cons (car xs) acc))))\n"
  "(define-constant (reverse-tail-recursive xs)\n"
  "  (reverse-tail-recursive-helper xs ()))\n"
  "\n"
  "(define-constant (reverse xs)\n"
  "  (reverse-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; reverse!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (reverse!-iterative xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (let* ((previous-list ())\n"
  "             (the-cons xs)\n"
  "             (following-list #f))\n"
  "        (while (not (null?"" the-cons))\n"
  "          (set! following-list (cdr the-cons))\n"
  "          (set-cdr! the-cons previous-list)\n"
  "          (set! previous-list the-cons)\n"
  "          (set! the-cons following-list))\n"
  "        previous-list)))\n"
  "\n"
  "(define-constant (reverse!-tail-recursive-helper outer-cons non-null-inner-list)\n"
  "  (let* ((old-non-null-inner-list-cdr (cdr non-null-inner-list)))\n"
  "    ;; outer-cons: (A . non-null-inner-list) , actually (A . (B . ?""))\n"
  "    ;; non-null-inner-list: (B . ?"")\n"
  "    (set-cdr! non-null-inner-list outer-cons)\n"
  "    (if (null?"" old-non-null-inner-list-cdr)\n"
  "        non-null-inner-list\n"
  "        (reverse!-tail-recursive-helper non-null-inner-list\n"
  "                                        old-non-null-inner-list-cdr))))\n"
  "(define-constant (reverse!-tail-recursive xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (reverse!-tail-recursive-helper () xs)))\n"
  "\n"
  "(define-constant (reverse! xs)\n"
  "  (reverse!-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; append.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (append-iterative xs ys)\n"
  "  (append-reversed-iterative (reverse-iterative xs) ys))\n"
  "\n"
  "(define-constant (append-non-tail-recursive xs ys)\n"
  "  (if (null?"" xs)\n"
  "      ys\n"
  "      (cons (car xs)\n"
  "            (append-non-tail-recursive (cdr xs) ys))))\n"
  "\n"
  "(define-constant (append-tail-recursive xs ys)\n"
  "  (append-reversed-tail-recursive (reverse-tail-recursive xs)\n"
  "                                  ys))\n"
  "\n"
  "(define-constant (append-procedure xs ys)\n"
  "  (append-iterative xs ys))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; append!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (append!-iterative xs ys)\n"
  "  (if (null?"" xs)\n"
  "      ys\n"
  "      (begin\n"
  "        (set-cdr! (last-cons-iterative xs) ys)\n"
  "        xs)))\n"
  "\n"
  "(define-constant (append!-tail-recursive xs ys)\n"
  "  (if (null?"" xs)\n"
  "      ys\n"
  "      (begin\n"
  "        (set-cdr! (last-cons-tail-recursive xs) ys)\n"
  "        xs)))\n"
  "\n"
  "(define-constant (append!-procedure xs ys)\n"
  "  (append!-iterative xs ys))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; flatten-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (flatten-reversed-iterative list-of-lists)\n"
  "  (let* ((res ()))\n"
  "    (while (non-null?"" list-of-lists)\n"
  "      (set! res (append-iterative (car list-of-lists) res))\n"
  "      (set! list-of-lists (cdr list-of-lists)))\n"
  "    res))\n"
  "\n"
  "(define-constant (flatten-reversed-tail-recursive-helper reversed-list acc)\n"
  "  (if (null?"" reversed-list)\n"
  "      acc\n"
  "      (flatten-reversed-tail-recursive-helper\n"
  "          (cdr reversed-list)\n"
  "          (append-tail-recursive (car reversed-list) acc))))\n"
  "(define-constant (flatten-reversed-tail-recursive reversed-list)\n"
  "  (flatten-reversed-tail-recursive-helper reversed-list ()))\n"
  "\n"
  "(define-constant (flatten-reversed reversed-list)\n"
  "  (flatten-reversed-iterative reversed-list))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; flatten-reversed!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (flatten-reversed!-iterative list-of-lists)\n"
  "  (let* ((res ()))\n"
  "    (while (non-null?"" list-of-lists)\n"
  "      (set! res (append!-iterative (car list-of-lists) res))\n"
  "      (set! list-of-lists (cdr list-of-lists)))\n"
  "    res))\n"
  "\n"
  "(define-constant (flatten-reversed! list-of-lists)\n"
  "  (flatten-reversed!-iterative list-of-lists))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; flatten.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (flatten-iterative list-of-lists)\n"
  "  (flatten-reversed-iterative (reverse-iterative list-of-lists)))\n"
  "\n"
  "(define-constant (flatten-tail-recursive list-of-lists)\n"
  "  (flatten-reversed-tail-recursive (reverse-tail-recursive list-of-lists)))\n"
  "\n"
  "(define-constant (flatten-non-tail-recursive list-of-lists)\n"
  "  (if (null?"" list-of-lists)\n"
  "      ()\n"
  "      (append-non-tail-recursive\n"
  "          (car list-of-lists)\n"
  "          (flatten-non-tail-recursive (cdr list-of-lists)))))\n"
  "\n"
  "(define-constant (flatten list-of-lists)\n"
  "  (flatten-iterative list-of-lists))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; flatten!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (flatten!-iterative list-of-lists)\n"
  "  (flatten-reversed!-iterative (reverse!-iterative list-of-lists)))\n"
  "\n"
  "(define-constant (flatten!-tail-recursive list-of-lists)\n"
  "  (flatten-reversed-tail-recursive (reverse!-tail-recursive list-of-lists)))\n"
  "\n"
  "(define-constant (flatten!-non-tail-recursive list-of-lists)\n"
  "  (if (null?"" list-of-lists)\n"
  "      ()\n"
  "      ;; I don't have an append!-non-tail-recursive, as it doesn't seem very\n"
  "      ;; reasonable.\n"
  "      (append!-procedure (car list-of-lists)\n"
  "                         (flatten!-non-tail-recursive (cdr list-of-lists)))))\n"
  "\n"
  "(define-constant (flatten! list-of-lists)\n"
  "  (flatten!-iterative list-of-lists))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; list-copy.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; These return a shallow-copy of the given list: only the spine is\n"
  ";;; duplicated.\n"
  "\n"
  "(define-constant (list-copy-iterative xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (let* ((res (cons (car xs) #f))\n"
  "             (last-cons res)\n"
  "             (new-cons #f))\n"
  "        (set! xs (cdr xs))\n"
  "        (while (non-null?"" xs)\n"
  "          (set! new-cons (cons (car xs) #f))\n"
  "          (set-cdr! last-cons new-cons)\n"
  "          (set! last-cons new-cons)\n"
  "          (set! xs (cdr xs)))\n"
  "        (set-cdr! last-cons ())\n"
  "        res)))\n"
  "\n"
  "(define-constant (list-copy-tail-recursive xs)\n"
  "  (reverse!-tail-recursive (reverse-tail-recursive xs)))\n"
  "\n"
  "(define-constant (list-copy-non-tail-recursive xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (cons (car xs)\n"
  "            (list-copy-non-tail-recursive (cdr xs)))))\n"
  "\n"
  "(define-constant (list-copy xs)\n"
  "  (list-copy-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; car-or-nil.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (car-or-nil xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (car xs)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; cdr-or-nil.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (cdr-or-nil xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (cdr xs)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; nth-cons-or-nil.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (nth-cons-or-nil-iterative xs n)\n"
  "  ;; A break or return form would be useful here.  Even better I could also\n"
  "  ;; iterate on an and condition, but we have no and macro yet.\n"
  "  (let* ((go-on #t))\n"
  "    (while go-on\n"
  "      (cond ((zero?"" n)\n"
  "             (set! go-on #f))\n"
  "            ((null?"" xs)\n"
  "             (set! go-on #f))\n"
  "            (else\n"
  "             (set! n (1- n))\n"
  "             (set! xs (cdr xs)))))\n"
  "    xs))\n"
  "\n"
  "(define-constant (nth-cons-or-nil-tail-recursive xs n)\n"
  "  (cond ((zero?"" n)\n"
  "         xs)\n"
  "        ((null?"" xs)\n"
  "         ())\n"
  "        (else\n"
  "         (nth-cons-or-nil-tail-recursive (cdr xs) (1- n)))))\n"
  "\n"
  "(define-constant (nth-cons-or-nil xs n)\n"
  "  (nth-cons-or-nil-iterative xs n))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; nth-cons.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (nth-cons xs n)\n"
  "  (let* ((c (nth-cons-or-nil n xs)))\n"
  "    (if (null?"" c)\n"
  "        (error '(nth-cons: list too short))\n"
  "        c)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; nth.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (nth-iterative xs n)\n"
  "  (while (non-zero?"" n)\n"
  "    (set! xs (cdr xs))\n"
  "    (set! n (1- n)))\n"
  "  (car xs))\n"
  "\n"
  "(define-constant (nth-tail-recursive xs n)\n"
  "  (if (zero?"" n)\n"
  "      (car xs)\n"
  "      (nth-tail-recursive (cdr xs) (1- n))))\n"
  "\n"
  "(define-constant (nth xs n)\n"
  "  (nth-iterative xs n))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; take, take-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";; A break or return form would be useful here.\n"
  "(define-constant (take-reversed-iterative xs n)\n"
  "  (let* ((res ())\n"
  "         (go-on #t))\n"
  "    (while go-on\n"
  "      (cond ((null?"" xs)\n"
  "             (set! go-on #f))\n"
  "            ((zero?"" n)\n"
  "             (set! go-on #f))\n"
  "            (else\n"
  "             (set! res (cons (car xs) res))\n"
  "             (set! xs (cdr xs))\n"
  "             (set! n (1- n)))))\n"
  "    res))\n"
  "(define-constant (take-iterative xs n)\n"
  "  (reverse!-iterative (take-reversed-iterative xs n)))\n"
  "\n"
  "(define-constant (take-tail-recursive xs n)\n"
  "  (reverse!-tail-recursive (take-reversed-tail-recursive xs n)))\n"
  "\n"
  "(define-constant (take-non-tail-recursive xs n)\n"
  "  (cond ((zero?"" n)\n"
  "         ())\n"
  "        ((null?"" xs)\n"
  "         ())\n"
  "        (else\n"
  "         (cons (car xs) (take-non-tail-recursive (cdr xs) (1- n))))))\n"
  "\n"
  "(define-constant (take-reversed-tail-recursive-helper xs n acc)\n"
  "  (cond ((zero?"" n)\n"
  "         acc)\n"
  "        ((null?"" xs)\n"
  "         acc)\n"
  "        (else\n"
  "         (take-reversed-tail-recursive-helper (cdr xs)\n"
  "                                              (1- n)\n"
  "                                              (cons (car xs) acc)))))\n"
  "(define-constant (take-reversed-tail-recursive xs n)\n"
  "  (take-reversed-tail-recursive-helper xs n ()))\n"
  "\n"
  "(define-constant (take-reversed xs n)\n"
  "  (take-reversed-iterative xs n))\n"
  "\n"
  "(define-constant (take xs n)\n"
  "  (take-iterative xs n))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; take!\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (take!-iterative xs n)\n"
  "  (if (zero?"" n)\n"
  "      ()\n"
  "      (let* ((n-1-th-cons-or-nil (nth-cons-or-nil-iterative xs (1- n))))\n"
  "        (if (non-null?"" n-1-th-cons-or-nil)\n"
  "            (set-cdr! n-1-th-cons-or-nil ()))\n"
  "        xs)))\n"
  "\n"
  "(define-constant (take!-tail-recursive-helper xs n)\n"
  "  (cond ((= n 1)\n"
  "         (if (null?"" xs)\n"
  "             'do-nothing\n"
  "             (set-cdr! xs ())))\n"
  "        ((null?"" xs))\n"
  "        (else\n"
  "         (take!-tail-recursive-helper (cdr xs) (1- n)))))\n"
  "(define-constant (take!-tail-recursive xs n)\n"
  "  (if (zero?"" n)\n"
  "      ()\n"
  "      (begin\n"
  "        (take!-tail-recursive-helper xs n)\n"
  "        xs)))\n"
  "\n"
  "(define-constant (take! xs n)\n"
  "  (take!-iterative xs n))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; drop.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";; A break or return form would be useful here.\n"
  "(define-constant (drop-iterative xs n)\n"
  "  (let* ((go-on #t))\n"
  "    (while go-on\n"
  "      (cond ((null?"" xs)\n"
  "             (set! go-on #f))\n"
  "            ((zero?"" n)\n"
  "             (set! go-on #f))\n"
  "            (else\n"
  "             (set! xs (cdr xs))\n"
  "             (set! n (1- n)))))\n"
  "    xs))\n"
  "\n"
  "(define-constant (drop-tail-recursive xs n)\n"
  "  (cond ((zero?"" n)\n"
  "         xs)\n"
  "        ((null?"" xs)\n"
  "         ())\n"
  "        (else\n"
  "         (drop-tail-recursive (cdr xs) (1- n)))))\n"
  "\n"
  "(define-constant (drop xs n)\n"
  "  (drop-iterative xs n))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; drop!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (drop! xs n)\n"
  "  (if (zero?"" n)\n"
  "      xs\n"
  "      (let* ((n-1-th-cons-or-nil (nth-cons-or-nil xs (1- n))))\n"
  "        (if (non-null?"" n-1-th-cons-or-nil)\n"
  "            (let* ((old-cdr (cdr n-1-th-cons-or-nil)))\n"
  "              (set-cdr! n-1-th-cons-or-nil ())\n"
  "              old-cdr)\n"
  "            ()))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; High-level macros.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; At this point I have a good implementation for the fundamental list\n"
  ";;; procedures, which lets me use quasiquoting in macros.\n"
  "\n"
  "\n"
  "\n"
  ";;;; destructuring-bind-procedure.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Rationale: Every low-level macro has exactly *one* formal parameter, always\n"
  ";;; named low-level-macro-args and bound to the entire macro call cdr.  Thru\n"
  ";;; destructuring-bind we can turn convenient high-level macros with named\n"
  ";;; formals into low-level macros, by binding each formal to a\n"
  ";;; low-level-macro-args component.\n"
  ";;;\n"
  ";;; The mapping from high-level to low-level macros is epsilon-style; at least,\n"
  ";;; I designed it the first time for epsilon.  I wouldn't be very surprised if\n"
  ";;; somebody had the same idea before, which may be the reason why\n"
  ";;; destructuring-bind exists in Common Lisp -- I discovered it after devising\n"
  ";;; my own mechanism, which originally had a different name but behaved\n"
  ";;; identically.\n"
  ";;; Update: the answer may be in http://www.lispworks.com/documentation/HyperSpec/Issues/iss130_w.htm\n"
  ";;; I've discovered Emacs Lisp's seq-let , less powerful but conceptually very\n"
  ";;; similar, only now in 2017.\n"
  "\n"
  ";;; Return the result of destructuring-bind with the given formal pattern bound\n"
  ";;; to low-level-macro-args or some sub-component of it.  The result is code,\n"
  ";;; not executed by this function: of course we cannot do that until we have an\n"
  ";;; actual value for low-level-macro-args .\n"
  ";;; Notice that component may be evaluated multiple times in the returned code,\n"
  ";;; and therefore should be a literal or a variable.  This is ensured out of\n"
  ";;; this recursive procedure, by calling it with an appropriate actual.\n"
  ";;; Common Lisp calls \"template\" what we call \"pattern\" here.\n"
  "(define-constant (destructuring-bind-recursive formals-pattern\n"
  "                                               component\n"
  "                                               body-forms)\n"
  "  (cond ((null?"" formals-pattern)\n"
  "         ;; There is nothing to bind in the pattern.  Return code to check\n"
  "         ;; that there are also no actuals, and then either proceeds or fails.\n"
  "         `(if (null?"" ,component)\n"
  "              (begin\n"
  "                ,@body-forms)\n"
  "              (error `(destructuring-bind: excess actuals: ,,component))))\n"
  "        ((symbol?"" formals-pattern)\n"
  "         ;; The macro pattern is dotted, or this is a recursive call on a\n"
  "         ;; pattern car: in either case bind one variable to every actual.\n"
  "         `(let* ((,formals-pattern ,component))\n"
  "            ,@body-forms))\n"
  "        ((cons?"" formals-pattern)\n"
  "         ;; Bind both the car and the cdr.  For efficiency's sake name the two\n"
  "         ;; sub-components in the generated code.\n"
  "         (let* ((car-name (gensym))\n"
  "                (cdr-name (gensym)))\n"
  "           `(let* ((,car-name (car ,component))\n"
  "                   (,cdr-name (cdr ,component)))\n"
  "              ,(destructuring-bind-recursive\n"
  "                  (car formals-pattern)\n"
  "                  car-name\n"
  "                  ;; The inner quasiquoting serves to make a (singleton) list of\n"
  "                  ;; the body forms.\n"
  "                  `(,(destructuring-bind-recursive (cdr formals-pattern)\n"
  "                                                   cdr-name\n"
  "                                                   body-forms))))))\n"
  "        ((vector?"" formals-pattern)\n"
  "         (error `(vector ,formals-pattern in macro formals pattern)))\n"
  "        (else\n"
  "         ;; The pattern is, hopefully, something which can be compared with eq?""\n"
  "         ;; .  Return code checking that it's equal to the actual and in that\n"
  "         ;; case proceeds without binding anything.\n"
  "         `(if (eq?"" ,formals-pattern ,component)\n"
  "              (begin\n"
  "                ,@body-forms)\n"
  "              (error `(non-matching pattern argument: ,formals-pattern\n"
  "                                    ,component))))))\n"
  "\n"
  ";;; The args argument represents \"actuals\" in a symbolic form; their values\n"
  ";;; may not necessarily be known yet.\n"
  ";;; Example:\n"
  ";;; (destructuring-bind-procedure\n"
  ";;;   '(a b)\n"
  ";;;   'some-arguments\n"
  ";;;   '((display a) (display b)))\n"
  ";;; This would return code binding a and b as local variable to the car and\n"
  ";;; cadr of some-arguments, assumed to be bound, and display them.\n"
  "(define-constant (destructuring-bind-procedure formals-pattern args body-forms)\n"
  "  (let* ((args-value-name (gensym)))\n"
  "    `(let* ((,args-value-name ,args))\n"
  "       ,(destructuring-bind-recursive formals-pattern\n"
  "                                      args-value-name\n"
  "                                      body-forms))))\n"
  "\n"
  ";; FIXME: check that the formals-pattern doesn't require non-linear bindings.\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; destructuring-bind.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; This will be convenient to define high-level macros on top of low-level\n"
  ";;; macros, by destructuring the one low-level macro argument.\n"
  "\n"
  ";;; Arguments: pattern structure . body-forms Evaluate structure and locally\n"
  ";;; bind its components with the variables in the pattern; return the result of\n"
  ";;; evaluating the body forms with the bindings visible.\n"
  "(define-constant destructuring-bind\n"
  "  (low-level-macro\n"
  "    (let* ((pattern (car low-level-macro-args))\n"
  "           (structure (cadr low-level-macro-args))\n"
  "           (body-forms (cddr low-level-macro-args)))\n"
  "      (destructuring-bind-procedure pattern structure body-forms))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level macros.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Expand to a form evaluating to a high-level macro.\n"
  ";;; Arguments: formals . body-forms\n"
  ";;; Scheme-style, where formals can be an improper list; however there is no\n"
  ";;; macro name here.\n"
  "(define-constant macro\n"
  "  (low-level-macro\n"
  "    (let* ((macro-formals (car low-level-macro-args))\n"
  "           (macro-body-forms (cdr low-level-macro-args)))\n"
  "      `(low-level-macro\n"
  "         (destructuring-bind ,macro-formals\n"
  "                             low-level-macro-args\n"
  "                             ,@macro-body-forms)))))\n"
  "\n"
  ";;; Globally define a high-level named macro.\n"
  ";;; Arguments: (name . pattern) . body-forms\n"
  ";;; The pattern is of the form accepted by destructuring-bind.\n"
  "(define-constant define-macro\n"
  "  (macro ((macro-name . macro-formals) . macro-body-forms)\n"
  "    `(define ,macro-name\n"
  "       (macro ,macro-formals ,@macro-body-forms))))\n"
  "\n"
  ";;; High-level macros are now usable.\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; More advanced list library.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;;; alist functions.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (alist?"" x)\n"
  "  (cond ((null?"" x)\n"
  "         #t)\n"
  "        ((non-cons?"" x)\n"
  "         #f)\n"
  "        ((cons?"" (car x))\n"
  "         (alist?"" (cdr x)))\n"
  "        (else\n"
  "         #f)))\n"
  "\n"
  "(define-constant (assq key alist)\n"
  "  (cond ((null?"" alist)\n"
  "         #f)\n"
  "        ((eq?"" (caar alist) key)\n"
  "         (car alist))\n"
  "        (else\n"
  "         (assq key (cdr alist)))))\n"
  "\n"
  "(define-constant (rassq value alist)\n"
  "  (cond ((null?"" alist)\n"
  "         #f)\n"
  "        ((eq?"" (cdar alist) value)\n"
  "         (car alist))\n"
  "        (else\n"
  "         (rassq value (cdr alist)))))\n"
  "\n"
  ";;; Return a new alist, possibly sharing structure with alist, without the\n"
  ";;; first binding of the given object, if any.\n"
  "(define-constant (del-assq-1-noncopying object alist)\n"
  "  (cond ((null?"" alist)\n"
  "         ())\n"
  "        ((eq?"" (caar alist) object)\n"
  "         (cdr alist))\n"
  "        (else\n"
  "         (cons (car alist) (del-assq-1-noncopying object (cdr alist))))))\n"
  "\n"
  "(define-constant (del-assq-1 object alist)\n"
  "  (del-assq-1-noncopying object (list-copy alist)))\n"
  "\n"
  "(define-constant (del-assq-noncopying object alist)\n"
  "  (cond ((null?"" alist)\n"
  "         ())\n"
  "        ((eq?"" (caar alist) object)\n"
  "         (del-assq-noncopying object (cdr alist)))\n"
  "        (else\n"
  "         (cons (car alist) (del-assq-noncopying object (cdr alist))))))\n"
  "\n"
  "(define-constant (del-assq object alist)\n"
  "  (del-assq-noncopying object (list-copy alist)))\n"
  "\n"
  ";;; An obvious extension of del-assq, returning a copy of the alist with the\n"
  ";;; bindings for all of the given keys removed.\n"
  "(define-constant (del-assq-list-noncopying objects alist)\n"
  "  (if (null?"" objects)\n"
  "      alist\n"
  "      (del-assq-list-noncopying (cdr objects)\n"
  "                                (del-assq-noncopying (car objects) alist))))\n"
  "\n"
  "(define-constant (del-assq-list objects alist)\n"
  "  (del-assq-list-noncopying objects (list-copy alist)))\n"
  "\n"
  ";; FIXME: implement del-assq! .\n"
  "\n"
  "(define-constant (alist-copy alist)\n"
  "  (let* ((res ())\n"
  "         (first-cons #f))\n"
  "    (while (non-null?"" alist)\n"
  "      (set! first-cons (car alist))\n"
  "      (set! res (cons (cons (car first-cons) (cdr first-cons)) res))\n"
  "      (set! alist (cdr alist)))\n"
  "    (reverse! res)))\n"
  "\n"
  "(define-constant (alist-get key alist)\n"
  "  (let* ((a-cons (assq key alist)))\n"
  "    (if (cons?"" a-cons)\n"
  "        (cdr a-cons)\n"
  "        (error `(alist-get: key ,key not found in alist ,alist)))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; zip-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (zip-reversed-iterative as bs)\n"
  "  (let* ((res ()))\n"
  "    (while (non-null?"" as)\n"
  "      (if (null?"" bs)\n"
  "          (error '(zip-reversed-iterative: first list longer))\n"
  "          (begin\n"
  "            (set! res (cons (cons (car as) (car bs))\n"
  "                            res))\n"
  "            (set! as (cdr as))\n"
  "            (set! bs (cdr bs)))))\n"
  "    (if (non-null?"" bs)\n"
  "        (error '(zip-reversed-iterative: second list longer)))\n"
  "    res))\n"
  "\n"
  "(define-constant (zip-reversed-tail-recursive-helper as bs acc)\n"
  "  (cond ((null?"" as)\n"
  "         (if (non-null?"" bs)\n"
  "             (error '(zip-non-tail-recursive: second list longer))\n"
  "             acc))\n"
  "        ((null?"" bs)\n"
  "         (error '(zip-tail-recursive: first list longer)))\n"
  "        (else\n"
  "         (zip-reversed-tail-recursive-helper (cdr as)\n"
  "                                             (cdr bs)\n"
  "                                             (cons (cons (car as)\n"
  "                                                         (car bs))\n"
  "                                                   acc)))))\n"
  "(define-constant (zip-reversed-tail-recursive as bs)\n"
  "  (zip-reversed-tail-recursive-helper as bs ()))\n"
  "\n"
  "(define-constant (zip-reversed as bs)\n"
  "  (zip-reversed-iterative as bs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; zip.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (zip-iterative as bs)\n"
  "  (reverse! (zip-reversed-iterative as bs)))\n"
  "\n"
  "(define-constant (zip-tail-recursive as bs)\n"
  "  (reverse!-tail-recursive (zip-reversed-tail-recursive as bs)))\n"
  "\n"
  "(define-constant (zip-non-tail-recursive as bs)\n"
  "  (cond ((null?"" as)\n"
  "         (if (non-null?"" bs)\n"
  "             (error '(zip-non-tail-recursive: second list longer))\n"
  "             ()))\n"
  "        ((null?"" bs)\n"
  "         (error '(zip-non-tail-recursive: first list longer)))\n"
  "        (else\n"
  "         (cons (cons (car as) (car bs))\n"
  "               (zip-non-tail-recursive (cdr as) (cdr bs))))))\n"
  "\n"
  "(define-constant (zip as bs)\n"
  "  (zip-iterative as bs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; unzip-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (unzip-reversed-iterative as)\n"
  "  (let* ((cars ())\n"
  "         (cdrs ()))\n"
  "    (while (non-null?"" as)\n"
  "      (set! cars (cons (caar as) cars))\n"
  "      (set! cdrs (cons (cdar as) cdrs))\n"
  "      (set! as (cdr as)))\n"
  "    (cons cars cdrs)))\n"
  "\n"
  "(define-constant (unzip-reversed-tail-recursive-helper as acc-cars acc-cdrs)\n"
  "  (if (null?"" as)\n"
  "      (cons acc-cars acc-cdrs)\n"
  "      (unzip-reversed-tail-recursive-helper (cdr as)\n"
  "                                            (cons (caar as) acc-cars)\n"
  "                                            (cons (cdar as) acc-cdrs))))\n"
  "(define-constant (unzip-reversed-tail-recursive as)\n"
  "  (unzip-reversed-tail-recursive-helper as () ()))\n"
  "\n"
  "(define-constant (unzip-reversed as)\n"
  "  (unzip-reversed-iterative as))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; unzip.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (unzip-iterative as)\n"
  "  (let* ((cons-reversed (unzip-reversed-iterative as)))\n"
  "    (cons (reverse! (car cons-reversed))\n"
  "          (reverse! (cdr cons-reversed)))))\n"
  "\n"
  "(define-constant (unzip-tail-recursive as)\n"
  "  (let* ((cons-reversed (unzip-reversed-tail-recursive as)))\n"
  "    (cons (reverse! (car cons-reversed))\n"
  "          (reverse! (cdr cons-reversed)))))\n"
  "\n"
  "(define-constant (unzip-non-tail-recursive as)\n"
  "  (if (null?"" as)\n"
  "      '(() . ())\n"
  "      (let* ((unzipped-cdr (unzip-non-tail-recursive (cdr as))))\n"
  "        (cons (cons (caar as) (car unzipped-cdr))\n"
  "              (cons (cdar as) (cdr unzipped-cdr))))))\n"
  "\n"
  "(define-constant (unzip as)\n"
  "  (unzip-iterative as))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; map!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (map!-iterative f xs)\n"
  "  (let* ((res xs))\n"
  "    (while (non-null?"" xs)\n"
  "      (set-car! xs (f (car xs)))\n"
  "      (set! xs (cdr xs)))\n"
  "    res))\n"
  "\n"
  "(define-constant (map!-tail-recursive-helper f xs)\n"
  "  (if (null?"" xs)\n"
  "      'done\n"
  "      (begin\n"
  "        (set-car! xs (f (car xs)))\n"
  "        (map!-tail-recursive-helper f (cdr xs)))))\n"
  "(define-constant (map!-tail-recursive f xs)\n"
  "  (map!-tail-recursive-helper f xs)\n"
  "  xs)\n"
  "\n"
  "(define-constant (map! f xs)\n"
  "  (map!-iterative f xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; map-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (map-reversed-iterative f xs)\n"
  "  (let* ((res ()))\n"
  "    (while (non-null?"" xs)\n"
  "      (set! res (cons (f (car xs)) res))\n"
  "      (set! xs (cdr xs)))\n"
  "    res))\n"
  "\n"
  "(define-constant (map-reversed-tail-recursive-helper f xs acc)\n"
  "  (if (null?"" xs)\n"
  "      acc\n"
  "      (map-reversed-tail-recursive-helper f\n"
  "                                          (cdr xs)\n"
  "                                          (cons (f (car xs))\n"
  "                                                acc))))\n"
  "(define-constant (map-reversed-tail-recursive f xs)\n"
  "  (map-reversed-tail-recursive-helper f xs ()))\n"
  "\n"
  "(define-constant (map-reversed f xs)\n"
  "  (map-reversed-iterative f xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; map.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (map-iterative f xs)\n"
  "  (reverse!-iterative (map-reversed-iterative f xs)))\n"
  "\n"
  "(define-constant (map-non-tail-recursive f xs)\n"
  "  (if (null?"" xs)\n"
  "      ()\n"
  "      (cons (f (car xs))\n"
  "            (map-non-tail-recursive f (cdr xs)))))\n"
  "\n"
  "(define-constant (map-tail-recursive f xs)\n"
  "  (reverse!-tail-recursive (map-reversed-tail-recursive f xs)))\n"
  "\n"
  "(define-constant (map f xs)\n"
  "  (map-iterative f xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; fold-left.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (fold-left-iterative f x xs)\n"
  "  (while (non-null?"" xs)\n"
  "    (set! x (f x (car xs)))\n"
  "    (set! xs (cdr xs)))\n"
  "  x)\n"
  "\n"
  "(define-constant (fold-left-iterative-reversed-f reversed-f x xs)\n"
  "  (while (non-null?"" xs)\n"
  "    (set! x (reversed-f (car xs) x))\n"
  "    (set! xs (cdr xs)))\n"
  "  x)\n"
  "\n"
  "(define-constant (fold-left-tail-recursive f x xs)\n"
  "  (if (null?"" xs)\n"
  "      x\n"
  "      (fold-left-tail-recursive f\n"
  "                                (f x (car xs))\n"
  "                                (cdr xs))))\n"
  "\n"
  "(define-constant (fold-left-tail-recursive-reversed-f reversed-f x xs)\n"
  "  (if (null?"" xs)\n"
  "      x\n"
  "      (fold-left-tail-recursive-reversed-f reversed-f\n"
  "                                           (reversed-f (car xs) x)\n"
  "                                           (cdr xs))))\n"
  "\n"
  "(define-constant (fold-left f x xs)\n"
  "  (fold-left-iterative f x xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; fold-right.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (fold-right-iterative f xs y)\n"
  "  (fold-left-iterative-reversed-f f\n"
  "                                  y\n"
  "                                  (reverse-iterative xs)))\n"
  "\n"
  "(define-constant (fold-right-tail-recursive f xs y)\n"
  "  (fold-left-tail-recursive-reversed-f f\n"
  "                                       y\n"
  "                                       (reverse-tail-recursive xs)))\n"
  "\n"
  "(define-constant (fold-right-non-tail-recursive f xs y)\n"
  "  (if (null?"" xs)\n"
  "      y\n"
  "      (f (car xs)\n"
  "         (fold-right-non-tail-recursive f (cdr xs) y))))\n"
  "\n"
  "(define-constant (fold-right f xs y)\n"
  "  (fold-right-iterative f xs y))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; fold-right!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (fold-right!-iterative f xs y)\n"
  "  (fold-left-iterative-reversed-f f\n"
  "                                  y\n"
  "                                  (reverse!-iterative xs)))\n"
  "\n"
  "(define-constant (fold-right! f xs y)\n"
  "  (fold-right!-iterative f xs y))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; exists?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";; FIXME: a return form would also be nice here.\n"
  "(define-constant (exists?""-iterative p xs)\n"
  "  (let* ((res #f)\n"
  "         (go-on #t))\n"
  "    (while go-on\n"
  "      (cond ((null?"" xs)\n"
  "             (set! go-on #f))\n"
  "            ((p (car xs))\n"
  "             (begin\n"
  "               (set! res #t)\n"
  "               (set! go-on #f)))\n"
  "            (else\n"
  "             (set! xs (cdr xs)))))\n"
  "    res))\n"
  "\n"
  "(define-constant (exists?""-tail-recursive p xs)\n"
  "  (cond ((null?"" xs)\n"
  "         #f)\n"
  "        ((p (car xs))\n"
  "         #t)\n"
  "        (else\n"
  "         (exists?""-tail-recursive p (cdr xs)))))\n"
  "\n"
  "(define-constant (exists?"" p xs)\n"
  "  (exists?""-iterative p xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; for-all?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";; FIXME: a return form would be nice here.\n"
  "(define-constant (for-all?""-iterative p xs)\n"
  "  (let* ((res #t)\n"
  "         (go-on #t))\n"
  "    (while go-on\n"
  "      (cond ((null?"" xs)\n"
  "             (set! go-on #f))\n"
  "            ((not (p (car xs)))\n"
  "             (begin\n"
  "               (set! res #f)\n"
  "               (set! go-on #f)))\n"
  "            (else\n"
  "             (set! xs (cdr xs)))))\n"
  "    res))\n"
  "\n"
  "(define-constant (for-all?""-tail-recursive p xs)\n"
  "  (cond ((null?"" xs)\n"
  "         #t)\n"
  "        ((p (car xs))\n"
  "         (for-all?""-tail-recursive p (cdr xs)))\n"
  "        (else\n"
  "         #f)))\n"
  "\n"
  "(define-constant (for-all?"" p xs)\n"
  "  (for-all?""-iterative p xs))\n"
  "\n"
  "\n"
  ";;;; filter, filter-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (filter-reversed-iterative p xs)\n"
  "  (let* ((res ()))\n"
  "    (while (non-null?"" xs)\n"
  "      (if (p (car xs))\n"
  "          (set! res (cons (car xs) res))\n"
  "          'do-nothing)\n"
  "      (set! xs (cdr xs)))\n"
  "    res))\n"
  "\n"
  "(define-constant (filter-iterative p xs)\n"
  "  (reverse!-iterative (filter-reversed-iterative p xs)))\n"
  "\n"
  "(define-constant (filter-non-tail-recursive p xs)\n"
  "  (cond ((null?"" xs)\n"
  "         ())\n"
  "        ((p (car xs))\n"
  "         (cons (car xs) (filter-non-tail-recursive p (cdr xs))))\n"
  "        (else\n"
  "         (filter-non-tail-recursive p (cdr xs)))))\n"
  "\n"
  "(define-constant (filter-reversed-tail-recursive-helper p xs acc)\n"
  "  (cond ((null?"" xs)\n"
  "         acc)\n"
  "        ((p (car xs))\n"
  "         (filter-reversed-tail-recursive-helper p (cdr xs) (cons (car xs) acc)))\n"
  "        (else\n"
  "         (filter-reversed-tail-recursive-helper p (cdr xs) acc))))\n"
  "(define-constant (filter-reversed-tail-recursive p xs)\n"
  "  (filter-reversed-tail-recursive-helper p xs ()))\n"
  "\n"
  "(define-constant (filter-tail-recursive p xs)\n"
  "  (reverse!-tail-recursive (filter-reversed-tail-recursive p xs)))\n"
  "\n"
  "(define-constant (filter-reversed p xs)\n"
  "  (filter-reversed-tail-recursive p xs))\n"
  "\n"
  "(define-constant (filter p xs)\n"
  "  (filter-tail-recursive p xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; range-reversed.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (range-reversed-iterative a b)\n"
  "  (let* ((res ()))\n"
  "    (while (<= a b)\n"
  "      (set! res (cons a res))\n"
  "      (set! a (1+ a)))\n"
  "    res))\n"
  "\n"
  "(define-constant (range-reversed-non-tail-recursive a b)\n"
  "  (if (> a b)\n"
  "      ()\n"
  "      (cons b (range-reversed-non-tail-recursive a (1- b)))))\n"
  "\n"
  "(define-constant (range-reversed-tail-recursive-helper a b acc)\n"
  "  (if (> a b)\n"
  "      acc\n"
  "      (range-reversed-tail-recursive-helper (1+ a) b (cons a acc))))\n"
  "(define-constant (range-reversed-tail-recursive a b)\n"
  "  (range-reversed-tail-recursive-helper a b ()))\n"
  "\n"
  "(define-constant (range-reversed a b)\n"
  "  (range-reversed-iterative a b))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; range.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (range-iterative a b)\n"
  "  (let* ((res ()))\n"
  "    (while (<= a b)\n"
  "      (set! res (cons b res))\n"
  "      (set! b (1- b)))\n"
  "    res))\n"
  "\n"
  "(define-constant (range-non-tail-recursive a b)\n"
  "  (if (> a b)\n"
  "      ()\n"
  "      (cons a (range-non-tail-recursive (1+ a) b))))\n"
  "\n"
  "(define-constant (range-tail-recursive-helper a b acc)\n"
  "  (if (> a b)\n"
  "      acc\n"
  "      (range-tail-recursive-helper a (1- b) (cons b acc))))\n"
  "(define-constant (range-tail-recursive a b)\n"
  "  (range-tail-recursive-helper a b ()))\n"
  "\n"
  "(define-constant (range a b)\n"
  "  (range-iterative a b))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; iota.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (iota-iterative n)\n"
  "  (let* ((res ()))\n"
  "    (while (> n 0)\n"
  "      (set! n (1- n))\n"
  "      (set! res (cons n res)))\n"
  "    res))\n"
  "\n"
  "(define-constant (iota-tail-recursive-helper n acc)\n"
  "  (if (< n 0)\n"
  "      acc\n"
  "      (iota-tail-recursive-helper (1- n) (cons n acc))))\n"
  "(define-constant (iota-tail-recursive n)\n"
  "  (iota-tail-recursive-helper (1- n) ()))\n"
  "\n"
  "(define-constant (iota-non-tail-recursive n)\n"
  "  (range-non-tail-recursive 0 (1- n)))\n"
  "\n"
  "(define-constant (iota n)\n"
  "  (iota-iterative n))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Sorting.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; insert.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; FIXME: a return or break form would be nice here.\n"
  "(define-constant (insert-iterative x xs)\n"
  "  (let* ((smaller-elements-reversed ())\n"
  "         (go-on #t))\n"
  "    (while go-on\n"
  "      (cond ((null?"" xs)\n"
  "             (set! go-on #f))\n"
  "            ((<= x (car xs))\n"
  "             (set! go-on #f))\n"
  "            (else\n"
  "             (set! smaller-elements-reversed\n"
  "                   (cons (car xs) smaller-elements-reversed))\n"
  "             (set! xs (cdr xs)))))\n"
  "    (append-reversed-iterative smaller-elements-reversed\n"
  "                               (cons x xs))))\n"
  "\n"
  "(define-constant (insert-tail-recursive-helper x xs smaller-elements-reversed)\n"
  "  (cond ((null?"" xs)\n"
  "         (append-reversed-tail-recursive smaller-elements-reversed\n"
  "                                         (singleton x)))\n"
  "        ((<= x (car xs))\n"
  "         (append-reversed-tail-recursive smaller-elements-reversed\n"
  "                                         (cons x xs)))\n"
  "        (else\n"
  "         (insert-tail-recursive-helper x\n"
  "                                       (cdr xs)\n"
  "                                       (cons (car xs)\n"
  "                                             smaller-elements-reversed)))))\n"
  "(define-constant (insert-tail-recursive x xs)\n"
  "  (insert-tail-recursive-helper x xs ()))\n"
  "\n"
  "(define-constant (insert-non-tail-recursive x xs)\n"
  "  (cond ((null?"" xs)\n"
  "         (singleton x))\n"
  "        ((<= x (car xs))\n"
  "         (cons x xs))\n"
  "        (else\n"
  "         (cons (car xs)\n"
  "               (insert-non-tail-recursive x (cdr xs))))))\n"
  "\n"
  "(define-constant (insert x xs)\n"
  "  (insert-iterative x xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; insert!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Destructively turn (A . B) into (x . (A . B)).\n"
  "(define-constant (insert-as-first! x a-cons)\n"
  "  (let* ((new-cons (cons (car a-cons) (cdr a-cons))))\n"
  "    (set-car! a-cons x)\n"
  "    (set-cdr! a-cons new-cons)))\n"
  "\n"
  ";;; Destructively turn (A . B) into (A . (x . B)).\n"
  "(define-constant (insert-as-second! x a-cons)\n"
  "  (let* ((new-cons (cons x (cdr a-cons))))\n"
  "    (set-cdr! a-cons new-cons)))\n"
  "\n"
  "(define-constant (insert!-iterative-non-null x xs)\n"
  "  (let* ((go-on #t))\n"
  "    (while go-on\n"
  "      ;; Here I can still assume that xs is not ().\n"
  "      (cond ((< x (car xs))\n"
  "             (begin\n"
  "               (insert-as-first! x xs)\n"
  "               (set! go-on #f)))\n"
  "            ((null?"" (cdr xs))\n"
  "             (begin\n"
  "               (insert-as-second! x xs)\n"
  "               (set! go-on #f)))\n"
  "            (else\n"
  "             (set! xs (cdr xs)))))))\n"
  "(define-constant (insert!-iterative x xs)\n"
  "  (if (null?"" xs)\n"
  "      (singleton x)\n"
  "      (begin\n"
  "        (insert!-iterative-non-null x xs)\n"
  "        xs)))\n"
  "\n"
  "(define-constant (insert!-tail-recursive-non-null x xs)\n"
  "  (cond ((< x (car xs))\n"
  "         (insert-as-first! x xs))\n"
  "        ((null?"" (cdr xs))\n"
  "         (insert-as-second! x xs))\n"
  "        (else\n"
  "         (insert!-tail-recursive-non-null x (cdr xs)))))\n"
  "(define-constant (insert!-tail-recursive x xs)\n"
  "  (if (null?"" xs)\n"
  "      (singleton x)\n"
  "      (begin\n"
  "        (insert!-tail-recursive-non-null x xs)\n"
  "        xs)))\n"
  "\n"
  "(define-constant (insert! x xs)\n"
  "  (insert!-iterative x xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; insertion-sort.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (insertion-sort-iterative xs)\n"
  "  (let* ((res ()))\n"
  "    (while (non-null?"" xs)\n"
  "      (set! res (insert!-iterative (car xs) res))\n"
  "      (set! xs (cdr xs)))\n"
  "    res))\n"
  "\n"
  "(define-constant (insertion-sort-tail-recursive-helper xs acc)\n"
  "  (if (null?"" xs)\n"
  "      acc\n"
  "      (insertion-sort-tail-recursive-helper (cdr xs)\n"
  "                                            (insert!-tail-recursive (car xs)\n"
  "                                                                    acc))))\n"
  "(define-constant (insertion-sort-tail-recursive xs)\n"
  "  (insertion-sort-tail-recursive-helper xs ()))\n"
  "\n"
  "(define-constant (insertion-sort xs)\n"
  "  (insertion-sort-iterative xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; sort.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (sort xs)\n"
  "  (insertion-sort xs))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Higher order.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; identity.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (identity x)\n"
  "  x)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; compose.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (compose-procedure f g)\n"
  "  (lambda (x) (f (g x))))\n"
  "\n"
  "(define-constant (compose-eta f g x)\n"
  "  (f (g x)))\n"
  "\n"
  "(define-constant (square-function f)\n"
  "  (lambda (x) (f (f x))))\n"
  "\n"
  "(define-constant (square-function-eta f x)\n"
  "  (f (f x)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; iterate.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (iterate-iterative-post f n)\n"
  "  (lambda (x)\n"
  "    (let* ((n n))\n"
  "      (while (> n 0)\n"
  "        (set! x (f x))\n"
  "        (set! n (1- n)))\n"
  "      x)))\n"
  "\n"
  "(define-constant (iterate-iterative-pre f n)\n"
  "  (let* ((res identity))\n"
  "    (while (> n 0)\n"
  "      (set! res (compose-procedure res f))\n"
  "      (set! n (1- n)))\n"
  "    res))\n"
  "\n"
  "(define-constant (iterate-eta f n x)\n"
  "  (if (zero?"" n)\n"
  "      x\n"
  "      (iterate-eta f (1- n) (f x))))\n"
  "(define-constant (iterate-tail-recursive-post f n)\n"
  "  (lambda (x) (iterate-eta f n x)))\n"
  "\n"
  ";; This builds a function which is even faster than the iterative versions (at\n"
  ";; least on the naïf JitterLisp interpreter).\n"
  "(define-constant (iterate-squaring-pre f n)\n"
  "  ;; This uses the same idea of exponentiation by squaring; the advantage here\n"
  "  ;; is the very small number of built closures, only O(lg n).  Recursion depth\n"
  "  ;; is also logarithmic, so non-tail calls are not a problem here.\n"
  "  (cond ((zero?"" n)\n"
  "         identity)\n"
  "        ((= n 1)\n"
  "         ;; An important case to optimize, in order to avoid compositions\n"
  "         ;; between f and the identity, which would be executed many times\n"
  "         ;; when the iterated function is eventually called.\n"
  "         f)\n"
  "        ((even?"" n)\n"
  "         (let* ((f^n/2 (iterate-squaring-pre f (quotient n 2))))\n"
  "           (square-function f^n/2)))\n"
  "        (else\n"
  "         (compose-procedure f (iterate-squaring-pre f (1- n))))))\n"
  "\n"
  "(define-constant (iterate-squaring-eta f n x)\n"
  "  ;; This uses the same idea of exponentiation by squaring; the advantage here\n"
  "  ;; is the very small number of built closures, only O(lg n).\n"
  "  (cond ((zero?"" n)\n"
  "         x)\n"
  "        ((even?"" n)\n"
  "         (iterate-squaring-eta (square-function f) (quotient n 2) x))\n"
  "        (else\n"
  "         (iterate-squaring-eta (square-function f) (quotient n 2) (f x)))))\n"
  "(define-constant (iterate-squaring-post f n)\n"
  "  (lambda (x) (iterate-squaring-eta f n x)))\n"
  "\n"
  "(define-constant (iterate-tail-recursive-pre-helper f n acc)\n"
  "  (if (zero?"" n)\n"
  "      acc\n"
  "      (iterate-tail-recursive-pre-helper f (1- n) (compose-procedure acc f))))\n"
  "(define-constant (iterate-tail-recursive-pre f n)\n"
  "  (iterate-tail-recursive-pre-helper f n identity))\n"
  "\n"
  "(define-constant (iterate-pre f n)\n"
  "  (iterate-squaring-pre f n))\n"
  "(define-constant (iterate-post f n)\n"
  "  (iterate-squaring-post f n))\n"
  "(define-constant (iterate f n)\n"
  "  (iterate-squaring-pre f n))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Stuff to move.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; The code below is okay, but should be moved up.\n"
  "\n"
  "\n"
  ";;;; list-has?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return non-#f iff x is eq?"" to at least one of the elements of xs, assumed\n"
  ";;; to be a list.\n"
  ";; (define-constant (list-has?"" xs x)\n"
  ";;   (let* ((res #f)\n"
  ";;          (done #f)) ;; A break or return form would be nice here.\n"
  ";;     (while (not done)\n"
  ";;       (cond ((null?"" xs)\n"
  ";;              (set! done #t))\n"
  ";;             ((eq?"" (car xs) x)\n"
  ";;              (set! res #t)\n"
  ";;              (set! done #t))\n"
  ";;             (else\n"
  ";;              (set! xs (cdr xs)))))\n"
  ";;     res))\n"
  "\n"
  "(define-constant (non-empty-list-has?"" xs x)\n"
  "  (let* ((res #f))\n"
  "    (while (not (null?"" xs))\n"
  "      (if (eq?"" (car xs) x)\n"
  "          (begin\n"
  "            (set! res #t)\n"
  "            (set! xs ()))\n"
  "          (set! xs (cdr xs))))\n"
  "    res))\n"
  "(define-constant (list-has?"" xs x)\n"
  "  (if (null?"" xs)\n"
  "      #f\n"
  "      (non-empty-list-has?"" xs x)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; list-without.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return a copy of the list xs, which may share structure with it, without the\n"
  ";;; first element which is eq?"" to x (if any), in the same order.\n"
  "\n"
  "(define-constant (list-without-iterative xs x)\n"
  "  (let* ((reversed-prefix ())\n"
  "         (go-on #t)) ;; A return statement would be nice.\n"
  "    (while go-on\n"
  "      (cond ((null?"" xs)\n"
  "             (set! go-on #f))\n"
  "            ((eq?"" (car xs) x)\n"
  "             (set! xs (cdr xs))\n"
  "             (set! go-on #f))\n"
  "            (else\n"
  "             (set! reversed-prefix (cons (car xs) reversed-prefix))\n"
  "             (set! xs (cdr xs)))))\n"
  "    (append!-iterative (reverse!-iterative reversed-prefix) xs)))\n"
  "\n"
  "(define-constant (list-without-tail-recursive-helper xs x acc)\n"
  "  (cond ((null?"" xs)\n"
  "         (reverse!-tail-recursive acc))\n"
  "        ((eq?"" (car xs) x)\n"
  "         (append!-tail-recursive (reverse!-tail-recursive acc)\n"
  "                                 (cdr xs)))\n"
  "        (else\n"
  "         (list-without-tail-recursive-helper (cdr xs)\n"
  "                                             x\n"
  "                                             (cons (car xs) acc)))))\n"
  "(define-constant (list-without-tail-recursive xs x)\n"
  "  (list-without-tail-recursive-helper xs x ()))\n"
  "\n"
  "(define-constant (list-without-non-tail-recursive xs x)\n"
  "  (cond ((null?"" xs)\n"
  "         ())\n"
  "        ((eq?"" (car xs) x)\n"
  "         (cdr xs))\n"
  "        (else\n"
  "         (cons (car xs)\n"
  "               (list-without-non-tail-recursive (cdr xs) x)))))\n"
  "\n"
  "(define-constant (list-without xs x)\n"
  "  (list-without-iterative xs x))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; list-without!.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";; Return the first cons of the list xs whose cadr is eq?"" to x, or () if no such\n"
  ";; cons exists.  In other word, return the cons containing the predecessor\n"
  ";; element of x in xs, or the list suffix whose second element is eq?"" to x.\n"
  ";; Assume that xs has at least one element.\n"
  "(define-constant (cons-before-or-nil xs x)\n"
  "  (let* ((go-on #t) ;; A break or return form would be nice here.\n"
  "         (next-cons (cdr xs)))\n"
  "    (while go-on\n"
  "      (cond ((null?"" next-cons)\n"
  "             (set! xs ())\n"
  "             (set! go-on #f))\n"
  "            ((eq?"" (car next-cons) x)\n"
  "             (set! go-on #f))\n"
  "            (else\n"
  "             (set! xs next-cons)\n"
  "             (set! next-cons (cdr next-cons)))))\n"
  "    ;; Now xs is either the predecessor we were looking for or ().\n"
  "    xs))\n"
  "\n"
  ";;; Return a list equal to xs except that the first element eq?"" to x, if any,\n"
  ";;; has been removed.  This may destructively modify xs, and the result may\n"
  ";;; share structure with it.\n"
  "(define-constant (list-without! xs x)\n"
  "  (cond ((null?"" xs)\n"
  "         ;; Empty list: there is nothing to remove.\n"
  "         ())\n"
  "        ((null?"" (cdr xs))\n"
  "         ;; Singleton: return an empty list or xs unchanged.\n"
  "         (if (eq?"" (car xs) x)\n"
  "             ()\n"
  "             xs))\n"
  "        ((eq?"" (car xs) x)\n"
  "         ;; Special case: if the equal element is the first then we cannot\n"
  "         ;; modify xs to turn it into the result, but we already have the\n"
  "         ;; result as a substructure of xs.\n"
  "         (cdr xs))\n"
  "        (else\n"
  "         ;; Here we may have the opportunity to actually modify the list.\n"
  "         ;; Find the predecessor cons, if any.\n"
  "         (let* ((predecessor-or-nil (cons-before-or-nil xs x)))\n"
  "           ;; If we found a predecessor then we just have to modify its cdr to\n"
  "           ;; skip the cons having x as car.  If we didn't find it there is\n"
  "           ;; nothing to remove.\n"
  "           (if (non-null?"" predecessor-or-nil) ;; We don't have when yet.\n"
  "               ;; Notice that cddr is safe here, as predecessor-or-nil is the\n"
  "               ;; predecessor of another element.\n"
  "               (set-cdr! predecessor-or-nil (cddr predecessor-or-nil)))\n"
  "           xs))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; all-different?"".\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; This is O(n^2).\n"
  "(define-constant (all-different?"" xs)\n"
  "  (cond ((null?"" xs)\n"
  "         #t)\n"
  "        ((list-has?"" (cdr xs) (car xs))\n"
  "         #f)\n"
  "        (else\n"
  "         (all-different?"" (cdr xs)))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level syntax: one-way conditionals.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-macro (when condition . body-forms)\n"
  "  `(if ,condition\n"
  "       (begin ,@body-forms)\n"
  "       (begin)))\n"
  "\n"
  "(define-macro (unless condition . body-forms)\n"
  "  `(if ,condition\n"
  "       (begin)\n"
  "       (begin ,@body-forms)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Variadic boolean connectives.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return a generalized boolean which is the logical disjunction of the given\n"
  ";;; clauses, evaluated left-to-right short-circuit; in case of a non-#f result\n"
  ";;; which exact value is returned is unspecified.\n"
  ";;; This definition is much laxer than the one common in other Lisp dialects;\n"
  ";;; see the comment before lispy-or for a rationale.\n"
  "(define-macro (or . clauses)\n"
  "  (cond ((null?"" clauses)\n"
  "         '#f)\n"
  "        ((non-cons?"" clauses)\n"
  "         (error '(or: non-list arguments)))\n"
  "        ((null?"" (cdr clauses))\n"
  "         (car clauses))\n"
  "        (else\n"
  "         `(if ,(car clauses)\n"
  "              '#t\n"
  "              (or ,@(cdr clauses))))))\n"
  "\n"
  ";;; Return a generalized boolean which is the logical conjunction of the given\n"
  ";;; clauses, evaluated left-to-right short-circuit; in case of a non-#f result\n"
  ";;; which exact value is returned is unspecified.\n"
  ";;; This specification is much laxer than the one common in other Lisp dialects,\n"
  ";;; for symmetry with the or macro above, but the implementation in this case\n"
  ";;; actually follows the Lisp tradition.  See the comment before lispy-or for a\n"
  ";;; rationale.\n"
  "(define-macro (and . clauses)\n"
  "  (cond ((null?"" clauses)\n"
  "         '#t)\n"
  "        ((non-cons?"" clauses)\n"
  "         (error '(and: non-list arguments)))\n"
  "        ((null?"" (cdr clauses))\n"
  "         (car clauses))\n"
  "        (else\n"
  "         `(if ,(car clauses)\n"
  "              (and ,@(cdr clauses))\n"
  "              '#f))))\n"
  "\n"
  ";;; This is a more typical Lisp-style variadic or operator returning the first\n"
  ";;; non-#f form result in case of a true conjunction.\n"
  ";;; The problem is that the nested let blocks it expands to will be difficult to\n"
  ";;; compile efficiently with the naïf code generator I have in mind for a stack\n"
  ";;; machine.  It would work well if I did liveness analysis, and reused\n"
  ";;; registers as soon as each variable died.\n"
  "(define-macro (lispy-or . args)\n"
  "  (cond ((null?"" args)\n"
  "         '#f)\n"
  "        ((null?"" (cdr args))\n"
  "         (car args))\n"
  "        (else\n"
  "         (let* ((first-name (gensym)))\n"
  "           `(let* ((,first-name ,(car args)))\n"
  "              (if ,first-name\n"
  "                  ,first-name\n"
  "                  (lispy-or ,@(cdr args))))))))\n"
  "\n"
  ";;; A variadic left-to-right short-circuit logical conjunction, returning the\n"
  ";;; result of the last clause in case of a non-#f result according to the Lisp\n"
  ";;; convention.\n"
  ";;; This is provided just for symmetry, since JitterLisp's default and operator\n"
  ";;; is already efficient, and differently from JitterLisp's or follows the Lisp\n"
  ";;; convention.\n"
  "(define lispy-and\n"
  "  and)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level syntax: let.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Rewrite something like\n"
  ";;;   (let ((a 1) (b 2) foo))\n"
  ";;; into something like\n"
  ";;;   (let* ((fresh-1 1) (fresh-2 2) (a fresh-1) (b fresh-2)) foo)\n"
  ";;; .  The redundant bindings will be optimized away by AST rewriting.\n"
  "(define-macro (let bindings . body-forms)\n"
  "  (unless (all-different?"" (map car bindings))\n"
  "    (error `(non-distinct let-bound variables in ,bindings)))\n"
  "  (let* ((fresh-variables (map (lambda (irrelevant) (gensym))\n"
  "                               bindings))\n"
  "         (fresh-variable-bindings (zip fresh-variables\n"
  "                                       (map cdr bindings)))\n"
  "         (user-variable-bindings (zip (map car bindings)\n"
  "                                      (map singleton fresh-variables))))\n"
  "    `(let* ,(append-procedure fresh-variable-bindings\n"
  "                              user-variable-bindings)\n"
  "       ,@body-forms)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level syntax: letrec.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-macro (letrec bindings . body-forms)\n"
  "  (unless (all-different?"" (map car bindings))\n"
  "    (error `(non-distinct letrec-bound variables in ,bindings)))\n"
  "  `(let* ,(map (lambda (binding) `(,(car binding) (undefined)))\n"
  "               bindings)\n"
  "     ,@(map (lambda (binding) `(set! ,(car binding) ,@(cdr binding)))\n"
  "            bindings)\n"
  "     ,@body-forms))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level syntax: named let.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-macro (named-let loop-name bindings . body-forms)\n"
  "  (unless (all-different?"" (map car bindings))\n"
  "    (error `(non-distinct named-let-bound variables in ,bindings)))\n"
  "  `(letrec ((,loop-name (lambda ,(map car bindings) ,@body-forms)))\n"
  "     (,loop-name ,@(map (lambda (binding) `(begin ,@(cdr binding)))\n"
  "                        bindings))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level syntax: Scheme-style let, either named or not.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Redefine the let form to expand to either the previously defined let form or\n"
  ";;; named-let, according to the shape of the first argument.  In order to do\n"
  ";;; this we first have to save the previous let macro, to be reused in one of\n"
  ";;; the two cases.\n"
  "(define-constant previous-let\n"
  "  let)\n"
  "(define-macro (let first-argument . other-arguments)\n"
  "  (if (symbol?"" first-argument)\n"
  "      `(named-let ,first-argument ,@other-arguments)\n"
  "      `(previous-let ,first-argument ,@other-arguments)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Variadic procedure composition.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Variadic procedure composition.\n"
  "(define-macro (compose . args)\n"
  "  (cond ((null?"" args)\n"
  "         'identity)\n"
  "        ((null?"" (cdr args))\n"
  "         (car args))\n"
  "        (else\n"
  "         `(compose-procedure ,(car args)\n"
  "                             (compose ,@(cdr args))))))\n"
  "\n"
  ";;; Sometimes it is convenient to write variadically composed procedures\n"
  ";;; in the order they are executed.  This is equivalent to a use of the\n"
  ";;; compose macro with its arguments in the opposite order, except that\n"
  ";;; the arguments of this macro are still evaluated left-to-right, in\n"
  ";;; the order they are written in the macro use.\n"
  "(define-macro (compose-pipeline . args)\n"
  "  (let ((procedure-names (map (lambda (useless) (gensym)) args)))\n"
  "    `(let* ,(zip procedure-names\n"
  "                 (map singleton args))\n"
  "       (compose ,@(reverse procedure-names)))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Variadic list or pseudo-list operations.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Given one or more arguments return their right-deep nested conses in order,\n"
  ";;; ending with the last element.  Evaluate elements in the given order.\n"
  ";;; Examples:\n"
  ";;;   (improper-list 1)      ==> 1\n"
  ";;;   (improper-list 1 2 3)  ==> (cons 1 (cons 2 3))\n"
  ";;;   (improper-list 1 2 ()) ==> (cons 1 (cons 2 ()))\n"
  "(define-macro (improper-list first-element . other-elements)\n"
  "  (if (null?"" other-elements)\n"
  "      first-element\n"
  "      `(cons ,first-element\n"
  "             (improper-list ,@other-elements))))\n"
  "\n"
  ";;; This is the usual Scheme name.\n"
  "(define cons*\n"
  "  improper-list)\n"
  "\n"
  "(define-macro (list . elements)\n"
  "  `(improper-list ,@elements ()))\n"
  "\n"
  "(define-macro (circular-list first-element . other-elements)\n"
  "  (let* ((res-name (gensym))\n"
  "         (cdr-name (gensym)))\n"
  "    `(let* ((,res-name (cons ,first-element #f))\n"
  "            (,cdr-name (improper-list ,@other-elements ,res-name)))\n"
  "       (set-cdr! ,res-name ,cdr-name)\n"
  "       ,res-name)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level syntax: case form.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";; FIXME: use let-macro\n"
  "(define-macro (case-variable-matches?"" variable literals)\n"
  "  (if (eq?"" literals 'else)\n"
  "      '#t\n"
  "      `(or ,@(map (lambda (a-literal)\n"
  "                    `(eq?"" ,variable ,a-literal))\n"
  "                  literals))))\n"
  "\n"
  ";; FIXME: use let-macro\n"
  "(define-macro (case-variable variable . clauses)\n"
  "  (if (null?"" clauses)\n"
  "      '(begin)\n"
  "      (begin\n"
  "        (unless (list?"" (car clauses))\n"
  "          (error `(case: non-list clause ,(car clauses))))\n"
  "        (unless (or (eq?"" (caar clauses) 'else)\n"
  "                    (list?"" (caar clauses)))\n"
  "          (error `(case: non-list non-else clause pattern ,(caar clauses))))\n"
  "        `(if (case-variable-matches?"" ,variable ,(caar clauses))\n"
  "             (begin ,@(cdar clauses))\n"
  "             (case-variable ,variable ,@(cdr clauses))))))\n"
  "\n"
  "(define-macro (case discriminand . clauses)\n"
  "  (let ((discriminand-variable (gensym)))\n"
  "    `(let ((,discriminand-variable ,discriminand))\n"
  "       (case-variable ,discriminand-variable ,@clauses))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level syntax: sequencing forms.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Evaluate forms in sequence, and return the result of the index-th one,\n"
  ";;; 1-based.  For example (begin-from-first 2 . forms) returns the result\n"
  ";;; of the second form.\n"
  "(define-macro (begin-from-first index . forms)\n"
  "  (unless (fixnum?"" index)\n"
  "    (error `(begin-from-first: non-fixnum index ,index)))\n"
  "  (unless (> index 0)\n"
  "    (error `(begin-from-first: non-positive index ,index)))\n"
  "  (unless (>= (length forms) index)\n"
  "    (error `(begin-from-first: not enough forms in ,@forms)))\n"
  "  (let ((result-variable (gensym))\n"
  "        (first-forms (take forms index))\n"
  "        (last-forms (drop forms index)))\n"
  "    `(let ((,result-variable ,@first-forms))\n"
  "       ,@last-forms\n"
  "       ,result-variable)))\n"
  "\n"
  "(define-macro (begin1 . forms)\n"
  "  `(begin-from-first 1 ,@forms))\n"
  "(define-macro (begin2 . forms)\n"
  "  `(begin-from-first 2 ,@forms))\n"
  "(define-macro (begin3 . forms)\n"
  "  `(begin-from-first 3 ,@forms))\n"
  "(define-macro (begin4 . forms)\n"
  "  `(begin-from-first 4 ,@forms))\n"
  "\n"
  ";;; Evaluate forms in sequence, and return the result of the index-th-to-last\n"
  ";;; one, 1-based.  For example (begin-from-last 2 . forms) returns the result\n"
  ";;; of the second-to-last form.  An index of 1 yields a macro functionally\n"
  ";;; equivalent to begin .\n"
  "(define-macro (begin-from-last index . forms)\n"
  "  (unless (fixnum?"" index)\n"
  "    (error `(begin-from-last: non-fixnum index ,index)))\n"
  "  (unless (> index 0)\n"
  "    (error `(begin-from-last: non-positive index ,index)))\n"
  "  (unless (>= (length forms) index)\n"
  "    (error `(begin-from-last: not enough forms in ,@forms)))\n"
  "  (let* ((result-variable (gensym))\n"
  "         (first-form-no (primordial-- (length forms) index))\n"
  "         (first-forms (take forms first-form-no))\n"
  "         (interesting-and-last-forms (drop forms first-form-no))\n"
  "         (interesting-form (car interesting-and-last-forms))\n"
  "         (last-forms (cdr interesting-and-last-forms)))\n"
  "    `(begin\n"
  "       ,@first-forms\n"
  "       (let ((,result-variable ,interesting-form))\n"
  "         ,@last-forms\n"
  "         ,result-variable))))\n"
  "\n"
  "(define-macro (begin-1 . forms)\n"
  "  `(begin-from-last 1 ,@forms))\n"
  "(define-macro (begin-2 . forms)\n"
  "  `(begin-from-last 2 ,@forms))\n"
  "(define-macro (begin-3 . forms)\n"
  "  `(begin-from-last 3 ,@forms))\n"
  "(define-macro (begin-4 . forms)\n"
  "  `(begin-from-last 4 ,@forms))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; High-level syntax: looping forms.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-macro (dotimes (variable limit . result-forms) . body-forms)\n"
  "  (let ((limit-name (gensym)))\n"
  "    `(let* ((,limit-name ,limit)\n"
  "            (,variable 0))\n"
  "       (while (< ,variable ,limit-name)\n"
  "         ,@body-forms\n"
  "         (set! ,variable (1+ ,variable)))\n"
  "       ,@result-forms)))\n"
  "\n"
  "(define-macro (dotimesdown (variable times . result-forms) . body-forms)\n"
  "  (let ((times-name (gensym)))\n"
  "    `(let ((,variable ,times))\n"
  "       (while (> ,variable 0)\n"
  "         (set! ,variable (1- ,variable))\n"
  "         ,@body-forms)\n"
  "       ,@result-forms)))\n"
  "\n"
  "(define-macro (dolist (variable list . result-forms) . body-forms)\n"
  "  (let ((list-name (gensym)))\n"
  "    `(let* ((,list-name ,list)\n"
  "            ;; This is currently faster than binding ,variable inside the loop.\n"
  "            (,variable (undefined)))\n"
  "       (while (non-null?"" ,list-name)\n"
  "         (set! ,variable (car ,list-name))\n"
  "         ,@body-forms\n"
  "         (set! ,list-name (cdr ,list-name)))\n"
  "       ,@result-forms)))\n"
  "\n"
  ";; An alternative version of dolist , with the same semantics.  This definition\n"
  ";; is likely more natural and should generate better compiled code, but will be\n"
  ";; worse on the current AST interpreter where let requires heap allocation.\n"
  "(define-macro (dolist-alt (variable list . result-forms) . body-forms)\n"
  "  (let ((list-name (gensym)))\n"
  "    `(let* ((,list-name ,list))\n"
  "       (while (non-null?"" ,list-name)\n"
  "         (let* ((,variable (car ,list-name)))\n"
  "           ,@body-forms\n"
  "           (set! ,list-name (cdr ,list-name))))\n"
  "       ,@result-forms)))\n"
  "\n"
  "(define-macro (do bindings (end-condition . result-forms) . body-forms)\n"
  "  `(let (,@(map (lambda (binding)\n"
  "                  `(,(car binding) ,(cadr binding)))\n"
  "               bindings))\n"
  "     (while (not ,end-condition)\n"
  "       ,@body-forms\n"
  "       ,@(flatten (map (lambda (binding)\n"
  "                         (if (null?"" (cddr binding))\n"
  "                             '()\n"
  "                             `((set! ,(car binding) ,@(cddr binding)))))\n"
  "                       bindings)))\n"
  "     ,@result-forms))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Macro-level iteration.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Expand to an expression evaluating the given operator applied to each of the\n"
  ";;; given operands, in sequence.  The expression is meant to have side effects,\n"
  ";;; for example by applying definition forms; its final result is #<nothing>.\n"
  "(define-macro (map-syntactically operator . operands)\n"
  "  (if (null?"" operands)\n"
  "      '(begin)\n"
  "      `(begin\n"
  "         (,operator ,(car operands))\n"
  "         (map-syntactically ,operator ,@(cdr operands)))))\n"
  "\n"
  ";;; Expand to an expression evaluating the given operators applied the one\n"
  ";;; operand (given as the last argument), in sequence.  The expression is meant\n"
  ";;; to have side effects, for example by applying definition, optimization or\n"
  ";;; disassembly forms; its final result is #<nothing>.\n"
  ";;; \"pam\" is \"map\" reversed, but I didn't use a \"-reverse\" suffix in the name\n"
  ";;; as that suggests that the list is reversed..\n"
  "(define-macro (pam-syntactically . operators-and-operand)\n"
  "  (let ((operators (all-but-last operators-and-operand))\n"
  "        (operand (last operators-and-operand)))\n"
  "    `(begin\n"
  "       ,@(map (lambda (operator) `(,operator ,operand))\n"
  "              operators))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Variadic operator procedures.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; It's quite convenient to define the machinery for nesting variadic operators\n"
  ";;; as left- or right-deep s-expressions thru procedures, and then to wrap\n"
  ";;; procedures into macros.  Defining macro-defining macros is more involved,\n"
  ";;; for no gain.\n"
  "\n"
  ";;; Return an s-expression encoding nested two-argument rator calls, using rands\n"
  ";;; as the operands to be evaluated in order.  The neutral rand is only used if\n"
  ";;; there are zero rands.  Nest on the neft.\n"
  ";;; Examples:\n"
  ";;;   (variadic-left-deep '+ 0 '(1 2 3)) ==> (+ (+ 1 2) 3)\n"
  ";;;   (variadic-left-deep '+ 0 '(1))     ==> 1\n"
  ";;;   (variadic-left-deep '+ 0 '())      ==> 0\n"
  "(define-constant (variadic-left-deep rator neutral rands)\n"
  "  (cond ((null?"" rands)\n"
  "         neutral)\n"
  "        ((null?"" (cdr rands))\n"
  "         (car rands))\n"
  "        (else\n"
  "         (let* ((last-rand (last rands))\n"
  "                (all-but-last-rands (all-but-last rands)))\n"
  "           `(,rator ,(variadic-left-deep rator neutral\n"
  "                                         all-but-last-rands)\n"
  "                    ,last-rand)))))\n"
  "\n"
  ";;; Like variadic-left-deep, but nesting on the right.\n"
  ";;; Examples:\n"
  ";;;   (variadic-right-deep '+ 0 '(1 2 3)) ==> (+ 1 (+ 2 3))\n"
  ";;;   (variadic-right-deep '+ 0 '(1))     ==> 1\n"
  ";;;   (variadic-right-deep '+ 0 '())      ==> 0\n"
  "(define-constant (variadic-right-deep rator neutral rands)\n"
  "  (cond ((null?"" rands)\n"
  "         neutral)\n"
  "        ((null?"" (cdr rands))\n"
  "         (car rands))\n"
  "        (else\n"
  "         `(,rator ,(car rands)\n"
  "                  ,(variadic-right-deep rator neutral (cdr rands))))))\n"
  "\n"
  ";;; Define operator as a variadic macro, composing the original-name rator\n"
  ";;; (itself a procedure, variable name or macro name) with the given\n"
  ";;; netural element.  Nest on the left.\n"
  "(define-macro (define-left-nested-variadic-extension operator original-name\n"
  "                neutral)\n"
  "  (let ((operands-name (gensym)))\n"
  "    `(define-macro (,operator . ,operands-name)\n"
  "       (variadic-left-deep ',original-name ',neutral ,operands-name))))\n"
  "\n"
  ";;; Like define-left-nested-variadic-extension, but nest on the right.\n"
  "(define-macro (define-right-nested-variadic-extension operator original-name\n"
  "                neutral)\n"
  "  (let ((operands-name (gensym)))\n"
  "    `(define-macro (,operator . ,operands-name)\n"
  "       (variadic-right-deep ',original-name ',neutral ,operands-name))))\n"
  "\n"
  ";;; Define a variadic operator thru define-left-nested-variadic-extension or\n"
  ";;; define-right-nested-variadic-extension ; it makes no difference which way\n"
  ";;; we nest for an associative operators, so use whichever one happens to be\n"
  ";;; more efficient in the current implementation.\n"
  "(define-macro (define-associative-variadic-extension operator\n"
  "                original-name neutral)\n"
  "  ;; With a strict left-to-right evaluation order nesting on the left yields\n"
  "  ;; better stack code.\n"
  "  `(define-left-nested-variadic-extension ,operator ,original-name ,neutral))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Variadic arithmetic.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-associative-variadic-extension +\n"
  "  primordial-+ 0)\n"
  "(define-associative-variadic-extension *\n"
  "  primordial-* 1)\n"
  "\n"
  "(define-macro (- . operands)\n"
  "  (cond ((null?"" operands)\n"
  "         (error '(-: no arguments)))\n"
  "        ((null?"" (cdr operands))\n"
  "         `(negate ,@operands))\n"
  "        (else\n"
  "         `(primordial-- ,(car operands)\n"
  "                        (+ ,@(cdr operands))))))\n"
  "\n"
  "(define-macro (/ . operands)\n"
  "  (cond ((null?"" operands)\n"
  "         (error '(/: no arguments)))\n"
  "        ((null?"" (cdr operands))\n"
  "         `(primordial-/ 1 ,@operands))\n"
  "        (else\n"
  "         `(primordial-/ ,(car operands)\n"
  "                        (* ,@(cdr operands))))))\n"
  "\n"
  "\n"
  ";;;; Squaring.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (square n)\n"
  "  (* n n))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Multiplication by additions (for fun).\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (*-nonnegative-b-by-sums-non-tail-recursive a b)\n"
  "  (cond ((zero?"" b)\n"
  "         0)\n"
  "        ((odd?"" b)\n"
  "         (+ a (*-nonnegative-b-by-sums-non-tail-recursive (2* a)\n"
  "                                                          (2quotient b))))\n"
  "        (else\n"
  "         (*-nonnegative-b-by-sums-non-tail-recursive (2* a)\n"
  "                                                     (2quotient b)))))\n"
  "(define-constant (*-by-sums-non-tail-recursive a b)\n"
  "  (if (< b 0)\n"
  "      (- (*-nonnegative-b-by-sums-non-tail-recursive a (- b)))\n"
  "      (*-nonnegative-b-by-sums-non-tail-recursive a b)))\n"
  "\n"
  "(define-constant (*-nonnegative-b-by-sums-iterative a b)\n"
  "  (let ((res 0))\n"
  "    (while (not (zero?"" b))\n"
  "      (when (odd?"" b)\n"
  "        (set! res (+ res a)))\n"
  "      (set! a (2* a))\n"
  "      (set! b (2quotient b)))\n"
  "    res))\n"
  "(define-constant (*-by-sums-iterative a b)\n"
  "  (if (< b 0)\n"
  "      (- (*-nonnegative-b-by-sums-iterative a (- b)))\n"
  "      (*-nonnegative-b-by-sums-iterative a b)))\n"
  "\n"
  "(define-constant (*-by-sums-procedure a b)\n"
  "  (*-by-sums-iterative a b))\n"
  "\n"
  "(define-left-nested-variadic-extension *-by-sums\n"
  "  ;; This is nested on the left, so that the second argument doesn't become\n"
  "  ;; bigger and bigger in nested calls.\n"
  "  *-by-sums-procedure 1)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Exponentiation.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (**-procedure-non-tail-recursive b e)\n"
  "  (cond ((zero?"" e)\n"
  "         1)\n"
  "        ((even?"" e)\n"
  "         (square (**-procedure-non-tail-recursive b (quotient e 2))))\n"
  "        (else\n"
  "         (* b (square (**-procedure-non-tail-recursive b (quotient e 2)))))))\n"
  "\n"
  "(define-constant (**-procedure-iterative b e)\n"
  "  (let ((res 1))\n"
  "    (while (not (zero?"" e))\n"
  "      (when (odd?"" e)\n"
  "        (set! res (* res b))\n"
  "        (set! e (- e 1)))\n"
  "      (set! e (quotient e 2))\n"
  "      (set! b (square b)))\n"
  "    res))\n"
  "\n"
  "(define-constant **-procedure\n"
  "  **-procedure-iterative)\n"
  "\n"
  "(define-right-nested-variadic-extension **-non-tail-recursive\n"
  "  **-procedure-non-tail-recursive 1)\n"
  "(define-right-nested-variadic-extension **-iterative\n"
  "  **-procedure-iterative 1)\n"
  "\n"
  "(define **\n"
  "  **-iterative)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Making non-variadic lambdas from possibly variadic operators.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; This is a convenient way to syntactically generate a lambda from a macro\n"
  ";;; name.\n"
  ";;; Example:\n"
  ";;;   (lambda-wrapper + 2)\n"
  ";;;   expands to something equivalent to\n"
  ";;;   (lambda (a b) (+ a b)) .\n"
  "(define-macro (lambda-wrapper rator arity)\n"
  "  (let ((formals (map (lambda (_) (gensym))\n"
  "                      (iota arity))))\n"
  "    `(lambda ,formals\n"
  "       (,rator ,@formals))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Variadic list operations.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Define variadic versions of append and append! , now finally with the\n"
  ";;; appropriate names meant for the user.\n"
  "(define-right-nested-variadic-extension append\n"
  "  append-procedure ())\n"
  "(define-right-nested-variadic-extension append!\n"
  "  append!-procedure ())\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Sets as lists.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Sets implemented as unordered lists without duplicates, elements compared\n"
  ";;; with eq?"" .\n"
  "\n"
  "(define-constant set-empty\n"
  "  ())\n"
  "\n"
  "(define-constant (set-empty?"" xs)\n"
  "  (null?"" xs))\n"
  "\n"
  "(define-constant (set-has?"" xs x)\n"
  "  (list-has?"" xs x))\n"
  "\n"
  "(define-constant (set-without-helper xs x reversed-left-part)\n"
  "  (cond ((null?"" xs)\n"
  "         reversed-left-part)\n"
  "        ((eq?"" (car xs) x)\n"
  "         (append! reversed-left-part (cdr xs)))\n"
  "        (else\n"
  "         (set-without-helper (cdr xs) x (cons (car xs) reversed-left-part)))))\n"
  "(define-constant (set-without xs x)\n"
  "  (set-without-helper xs x ()))\n"
  "\n"
  "(define-constant (set-with xs x)\n"
  "  (cons x (set-without xs x)))\n"
  "\n"
  "(define-constant (set-singleton x)\n"
  "  (singleton x))\n"
  "\n"
  "(define-constant (set-unite-procedure xs ys)\n"
  "  (if (null?"" ys)\n"
  "      xs\n"
  "      (set-unite-procedure (set-with xs (car ys)) (cdr ys))))\n"
  "\n"
  "(define-constant (set-subtract-procedure xs ys)\n"
  "  (if (null?"" ys)\n"
  "      xs\n"
  "      (set-subtract-procedure (set-without xs (car ys)) (cdr ys))))\n"
  "\n"
  "(define-constant (set-intersect-helper xs ys acc)\n"
  "  (if (null?"" ys)\n"
  "      acc\n"
  "      (let* ((car-ys (car ys))\n"
  "             (new-acc (if (set-has?"" xs car-ys)\n"
  "                          (cons car-ys acc)\n"
  "                          acc)))\n"
  "        (set-intersect-helper xs\n"
  "                              (cdr ys)\n"
  "                              new-acc))))\n"
  "(define-constant (set-intersect-procedure xs ys)\n"
  "  (set-intersect-helper xs ys ()))\n"
  "\n"
  ";;; Define variadic extensions for the union, intersection and subtraction\n"
  ";;; operations.\n"
  "(define-associative-variadic-extension set-unite\n"
  "  set-unite-procedure set-empty)\n"
  "(define-associative-variadic-extension set-intersect\n"
  "  set-intersect-procedure set-empty)\n"
  "(define-macro (set-subtract first-set . other-sets)\n"
  "  `(set-subtract-procedure ,first-set (set-unite ,@other-sets)))\n"
  "\n"
  "(define-constant (list->set list)\n"
  "  ;; This relies on set-unite-procedure recurring on its second argument.\n"
  "  (set-unite-procedure set-empty list))\n"
  "\n"
  ";;; Return a fresh set-as-list containing the given elements, each to be\n"
  ";;; evaluated left-to-right.  Duplicates are removed.\n"
  "(define-macro (set . elements)\n"
  "  (if (null?"" elements)\n"
  "      ()\n"
  "      ;; This is slightly complicated by the need to keep the evaluation order\n"
  "      ;; intuitive: macro arguments are to be evaluated left-to-right.\n"
  "      (let ((element-name (gensym))\n"
  "            (subset-name (gensym)))\n"
  "        ;; Using let* rather than let here is just an optimization.\n"
  "        `(let* ((,element-name ,(car elements))\n"
  "                (,subset-name (set ,@(cdr elements))))\n"
  "           (set-with ,subset-name ,element-name)))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Tentative features, or experimentation just for fun.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; Streams.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant stream-empty\n"
  "  '(#t . ()))\n"
  "\n"
  "(define-constant (stream-ready?"" s)\n"
  "  (car s))\n"
  "\n"
  "(define-constant (stream-force! s)\n"
  "  (unless (stream-ready?"" s)\n"
  "    (set-cdr! s ((cdr s)))\n"
  "    (set-car! s #t))\n"
  "  (cdr s))\n"
  "\n"
  "(define-constant (stream-null?"" s)\n"
  "  (null?"" (stream-force! s)))\n"
  "(define-constant (stream-non-null?"" s)\n"
  "  (non-null?"" (stream-force! s)))\n"
  "(define-constant (stream-car s)\n"
  "  (car (stream-force! s)))\n"
  "(define-constant (stream-cdr s)\n"
  "  (cdr (stream-force! s)))\n"
  "(define-constant (stream-set-car! s new-car)\n"
  "  (set-car! (stream-force! s) new-car))\n"
  "(define-constant (stream-set-cdr! s new-cdr)\n"
  "  (set-cdr! (stream-force! s) new-cdr))\n"
  "\n"
  "(define-macro (stream-cons x s)\n"
  "  `(cons #f\n"
  "         (lambda ()\n"
  "           (cons ,x ,s))))\n"
  "\n"
  "(define-macro (stream-delay stream-expression)\n"
  "  `(cons #f\n"
  "         (lambda ()\n"
  "           (stream-force! ,stream-expression))))\n"
  "\n"
  "(define-constant (stream-forever-1 x)\n"
  "  (letrec ((res (stream-delay (stream-cons x res))))\n"
  "    res))\n"
  "\n"
  "(define-constant (stream-ones)\n"
  "  (stream-forever-1 1))\n"
  "\n"
  "(define-constant (stream-from from)\n"
  "  (stream-cons from (stream-from (1+ from))))\n"
  "(define-constant (stream-naturals)\n"
  "  (stream-from 0))\n"
  "\n"
  "(define-constant (stream-walk-elements procedure s)\n"
  "  (while (stream-non-null?"" s)\n"
  "    (procedure (stream-car s))\n"
  "    (set! s (stream-cdr s))))\n"
  "\n"
  "(define-constant (stream-print-elements s)\n"
  "  (stream-walk-elements (lambda (x)\n"
  "                          (display x)\n"
  "                          (newline))\n"
  "                        s))\n"
  "\n"
  "(define-constant (stream-touch-elements s)\n"
  "  (stream-walk-elements (lambda (x))\n"
  "                        s))\n"
  "\n"
  "(define-constant (stream-range a b)\n"
  "  (if (> a b)\n"
  "      stream-empty\n"
  "      (stream-cons a (stream-range (1+ a) b))))\n"
  "\n"
  "(define-constant (stream-append s1 s2)\n"
  "  (stream-delay\n"
  "    (if (stream-null?"" s1)\n"
  "        s2\n"
  "        (stream-cons (stream-car s1)\n"
  "                     (stream-append (stream-cdr s1) s2)))))\n"
  "\n"
  "(define-constant (stream-forever-stream s)\n"
  "  (letrec ((res (stream-delay (stream-append s res))))\n"
  "    res))\n"
  "\n"
  "(define-constant (stream-filter p?"" s)\n"
  "  (stream-delay\n"
  "    (cond ((stream-null?"" s)\n"
  "           stream-empty)\n"
  "          ((p?"" (stream-car s))\n"
  "           (stream-cons (stream-car s)\n"
  "                        (stream-filter p?"" (stream-cdr s))))\n"
  "          (else\n"
  "           (stream-filter p?"" (stream-cdr s))))))\n"
  "\n"
  "(define-constant (stream-map f s)\n"
  "  (stream-delay\n"
  "    (if (stream-null?"" s)\n"
  "        stream-empty\n"
  "        (stream-cons (f (stream-car s))\n"
  "                     (stream-map f (stream-cdr s))))))\n"
  "\n"
  "(define-constant (stream-take s n)\n"
  "  (stream-delay\n"
  "    (cond ((zero?"" n)\n"
  "           stream-empty)\n"
  "          ((stream-null?"" s)\n"
  "           stream-empty)\n"
  "          (else\n"
  "           (stream-cons (stream-car s)\n"
  "                        (stream-take (stream-cdr s) (1- n)))))))\n"
  "\n"
  "(define-constant (stream-drop s n)\n"
  "  (stream-delay\n"
  "    (cond ((zero?"" n)\n"
  "           s)\n"
  "          ((stream-null?"" s)\n"
  "           stream-empty)\n"
  "          (else\n"
  "           (stream-drop (stream-cdr s) (1- n))))))\n"
  "\n"
  "(define-constant (stream-fold-left f x xs)\n"
  "  (if (stream-null?"" xs)\n"
  "      x\n"
  "      (stream-fold-left f\n"
  "                        (f x (stream-car xs))\n"
  "                        (stream-cdr xs))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; AST optimization.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compute the set of variables occurring free in an AST.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return a set-as-list of the variables occurring free in the given AST.\n"
  "(define-constant (ast-free ast)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         set-empty)\n"
  "        ((ast-variable?"" ast)\n"
  "         (set-singleton (ast-variable-name ast)))\n"
  "        ((ast-define?"" ast)\n"
  "         ;; The defined variable is global, and doesn't enter the picture at\n"
  "         ;; all.\n"
  "         (ast-free (ast-define-body ast)))\n"
  "        ((ast-if?"" ast)\n"
  "         (set-unite (ast-free (ast-if-condition ast))\n"
  "                    (ast-free (ast-if-then ast))\n"
  "                    (ast-free (ast-if-else ast))))\n"
  "        ((ast-set!?"" ast)\n"
  "         ;; An assigned variable *is* a reference in the sense of this\n"
  "         ;; procedure, differently from a defined global.  Of course the\n"
  "         ;; modified binding may be global, but the variable is free.\n"
  "         (set-with (ast-free (ast-set!-body ast))\n"
  "                   (ast-set!-name ast)))\n"
  "        ((ast-while?"" ast)\n"
  "         (set-unite (ast-free (ast-while-guard ast))\n"
  "                    (ast-free (ast-while-body ast))))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-free-list (ast-primitive-operands ast)))\n"
  "        ((ast-call?"" ast)\n"
  "         (set-unite (ast-free (ast-call-operator ast))\n"
  "                    (ast-free-list (ast-call-operands ast))))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (set-subtract (ast-free (ast-lambda-body ast))\n"
  "                       (ast-lambda-formals ast)))\n"
  "        ((ast-let?"" ast)\n"
  "         (set-unite (ast-free (ast-let-bound-form ast))\n"
  "                    (set-without (ast-free (ast-let-body ast))\n"
  "                                 (ast-let-bound-name ast))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (set-unite (ast-free (ast-sequence-first ast))\n"
  "                    (ast-free (ast-sequence-second ast))))))\n"
  "\n"
  ";;; Return a set-as-list of the free variables in the given list of ASTs.\n"
  "(define-constant (ast-free-list asts)\n"
  "  (if (null?"" asts)\n"
  "      set-empty\n"
  "      (set-unite (ast-free (car asts))\n"
  "                 (ast-free-list (cdr asts)))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Check whether a given variable occurs free in an AST.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return non-#f iff the given variable occurs free in the given AST.\n"
  "(define-constant (ast-has-free?"" ast x)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         #f)\n"
  "        ((ast-variable?"" ast)\n"
  "         (eq?"" (ast-variable-name ast) x))\n"
  "        ((ast-define?"" ast)\n"
  "         ;; The defined variable is global, and doesn't enter the picture.\n"
  "         (ast-has-free?"" (ast-define-body ast) x))\n"
  "        ((ast-if?"" ast)\n"
  "         (or (ast-has-free?"" (ast-if-condition ast) x)\n"
  "             (ast-has-free?"" (ast-if-then ast) x)\n"
  "             (ast-has-free?"" (ast-if-else ast) x)))\n"
  "        ((ast-set!?"" ast)\n"
  "         ;; An assigned variable *is* a reference in the sense of this\n"
  "         ;; procedure, differently from a defined global.  Of course the\n"
  "         ;; modified binding may be global, but the variable is free.\n"
  "         (or (eq?"" (ast-set!-name ast) x)\n"
  "             (ast-has-free?"" (ast-set!-body ast) x)))\n"
  "        ((ast-while?"" ast)\n"
  "         (or (ast-has-free?"" (ast-while-guard ast) x)\n"
  "             (ast-has-free?"" (ast-while-body ast) x)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-has-free?""-list (ast-primitive-operands ast) x))\n"
  "        ((ast-call?"" ast)\n"
  "         (or (ast-has-free?"" (ast-call-operator ast) x)\n"
  "             (ast-has-free?""-list (ast-call-operands ast) x)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (if (set-has?"" (ast-lambda-formals ast) x)\n"
  "             #f\n"
  "             (ast-has-free?"" (ast-lambda-body ast) x)))\n"
  "        ((ast-let?"" ast)\n"
  "         (if (eq?"" (ast-let-bound-name ast) x)\n"
  "             (ast-has-free?"" (ast-let-bound-form ast) x)\n"
  "             (or (ast-has-free?"" (ast-let-bound-form ast) x)\n"
  "                 (ast-has-free?"" (ast-let-body ast) x))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (or (ast-has-free?"" (ast-sequence-first ast) x)\n"
  "             (ast-has-free?"" (ast-sequence-second ast) x)))))\n"
  "\n"
  ";;; An extension of ast-has-free?"" to a list of ASTs.\n"
  "(define-constant (ast-has-free?""-list asts x)\n"
  "  (and (non-null?"" asts)\n"
  "       (or (ast-has-free?"" (car asts) x)\n"
  "           (ast-has-free?""-list (cdr asts) x))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Tentative: assigned variables in an AST.  [FIXME: remove unless I use this]\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; A set! form counts as an assignment; a define form doesn't, as a\n"
  ";;; define'd variable in JitterLisp is always a global, and globals\n"
  ";;; can't be renamed.\n"
  "\n"
  ";;; Return a set-as-list of the free variables being set! in the given AST.\n"
  "(define-constant (ast-assigned ast)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         set-empty)\n"
  "        ((ast-variable?"" ast)\n"
  "         set-empty)\n"
  "        ((ast-define?"" ast)\n"
  "         ;; The defined variable is global: see the comment above.\n"
  "         (ast-assigned (ast-define-body ast)))\n"
  "        ((ast-if?"" ast)\n"
  "         (set-unite (ast-assigned (ast-if-condition ast))\n"
  "                    (ast-assigned (ast-if-then ast))\n"
  "                    (ast-assigned (ast-if-else ast))))\n"
  "        ((ast-set!?"" ast)\n"
  "         (set-with (ast-assigned (ast-set!-body ast))\n"
  "                   (ast-set!-name ast)))\n"
  "        ((ast-while?"" ast)\n"
  "         (set-unite (ast-assigned (ast-while-guard ast))\n"
  "                    (ast-assigned (ast-while-body ast))))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-assigned-list (ast-primitive-operands ast)))\n"
  "        ((ast-call?"" ast)\n"
  "         (set-unite (ast-assigned (ast-call-operator ast))\n"
  "                    (ast-assigned-list (ast-call-operands ast))))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (set-subtract (ast-assigned (ast-lambda-body ast))\n"
  "                       (ast-lambda-formals ast)))\n"
  "        ((ast-let?"" ast)\n"
  "         (set-unite (ast-assigned (ast-let-bound-form ast))\n"
  "                    (set-without (ast-assigned (ast-let-body ast))\n"
  "                                 (ast-let-bound-name ast))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (set-unite (ast-assigned (ast-sequence-first ast))\n"
  "                    (ast-assigned (ast-sequence-second ast))))))\n"
  "\n"
  ";;; Return a set-as-list of the free variables being set! in the given list of\n"
  ";;; ASTs.\n"
  "(define-constant (ast-assigned-list asts)\n"
  "  (if (null?"" asts)\n"
  "      set-empty\n"
  "      (set-unite (ast-assigned (car asts))\n"
  "                 (ast-assigned-list (cdr asts)))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Assigned variables in an AST.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; A set! form counts as an assignment; a define form doesn't, as a\n"
  ";;; define'd variable in JitterLisp is always a global, and globals\n"
  ";;; can't be renamed by alpha-conversion.\n"
  "\n"
  ";;; Return non-#f iff any free occurrence of the given variable is set! in the\n"
  ";;; given AST.\n"
  "(define-constant (ast-has-assigned?"" ast x)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         #f)\n"
  "        ((ast-variable?"" ast)\n"
  "         #f)\n"
  "        ((ast-define?"" ast)\n"
  "         ;; The defined variable is global: see the comment above.\n"
  "         (ast-has-assigned?"" (ast-define-body ast) x))\n"
  "        ((ast-if?"" ast)\n"
  "         (or (ast-has-assigned?"" (ast-if-condition ast) x)\n"
  "             (ast-has-assigned?"" (ast-if-then ast) x)\n"
  "             (ast-has-assigned?"" (ast-if-else ast) x)))\n"
  "        ((ast-set!?"" ast)\n"
  "         (or (eq?"" (ast-set!-name ast) x)\n"
  "             (ast-has-assigned?"" (ast-set!-body ast) x)))\n"
  "        ((ast-while?"" ast)\n"
  "         (or (ast-has-assigned?"" (ast-while-guard ast) x)\n"
  "             (ast-has-assigned?"" (ast-while-body ast) x)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-has-assigned?""-list (ast-primitive-operands ast) x))\n"
  "        ((ast-call?"" ast)\n"
  "         (or (ast-has-assigned?"" (ast-call-operator ast) x)\n"
  "             (ast-has-assigned?""-list (ast-call-operands ast) x)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (if (set-has?"" (ast-lambda-formals ast) x)\n"
  "             #f\n"
  "             (ast-has-assigned?"" (ast-lambda-body ast) x)))\n"
  "        ((ast-let?"" ast)\n"
  "         (if (eq?"" (ast-let-bound-name ast) x)\n"
  "             (ast-has-assigned?"" (ast-let-bound-form ast) x)\n"
  "             (or (ast-has-assigned?"" (ast-let-bound-form ast) x)\n"
  "                 (ast-has-assigned?"" (ast-let-body ast) x))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (or (ast-has-assigned?"" (ast-sequence-first ast) x)\n"
  "             (ast-has-assigned?"" (ast-sequence-second ast) x)))))\n"
  "\n"
  ";;; An extension of ast-has-assigned?"" to a list of ASTs.\n"
  "(define-constant (ast-has-assigned?""-list asts x)\n"
  "  (and (non-null?"" asts)\n"
  "       (or (ast-has-assigned?"" (car asts) x)\n"
  "           (ast-has-assigned?""-list (cdr asts) x))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Non-locally used variables in an AST.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Check whether a variable is accessed non-locally, thru a lambda occurring\n"
  ";;; within the given AST.  For the purposes of this definition nested lets do\n"
  ";;; not count: only lambdas introduce the kind of non-locality we care about.\n"
  ";;; Variables shadowed in the lambda don't count eihter (but there shouldn't\n"
  ";;; be any, as this is supposed to be used on an already alpha-converted AST).\n"
  "\n"
  ";;; Return non-#f iff any free occurrence of the given variable occurs free in a\n"
  ";;; lambda syntactically contained within the given AST.\n"
  "(define-constant (ast-nonlocally-uses?"" ast x)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         #f)\n"
  "        ((ast-variable?"" ast)\n"
  "         #f)\n"
  "        ((ast-define?"" ast)\n"
  "         ;; The defined variable is global, and therefore irrelevant here.\n"
  "         (ast-nonlocally-uses?"" (ast-define-body ast) x))\n"
  "        ((ast-if?"" ast)\n"
  "         (or (ast-nonlocally-uses?"" (ast-if-condition ast) x)\n"
  "             (ast-nonlocally-uses?"" (ast-if-then ast) x)\n"
  "             (ast-nonlocally-uses?"" (ast-if-else ast) x)))\n"
  "        ((ast-set!?"" ast)\n"
  "         ;; By itself this assignment, even if it were on x, is irrelevant\n"
  "         ;; because it's not within a lambda.  However the set! body might\n"
  "         ;; contain a lambda using x.\n"
  "         (ast-nonlocally-uses?"" (ast-set!-body ast) x))\n"
  "        ((ast-while?"" ast)\n"
  "         (or (ast-nonlocally-uses?"" (ast-while-guard ast) x)\n"
  "             (ast-nonlocally-uses?"" (ast-while-body ast) x)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-nonlocally-uses?""-list (ast-primitive-operands ast) x))\n"
  "        ((ast-call?"" ast)\n"
  "         (or (ast-nonlocally-uses?"" (ast-call-operator ast) x)\n"
  "             (ast-nonlocally-uses?""-list (ast-call-operands ast) x)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         ;; This is the interesting case.\n"
  "         (if (set-has?"" (ast-lambda-formals ast) x)\n"
  "             ;; Shadowing: any occurrence of x within the lambda doesn't refer\n"
  "             ;; the same x.\n"
  "             #f\n"
  "             ;; The lambda formals don't shadow x.  Check whether x occurs free\n"
  "             ;; in the lambda body, which includes any sub-lambda.  Checking for\n"
  "             ;; only free occurrences is essential: we don't want the analysis\n"
  "             ;; to be fooled by deeper shadowing within the lambda.\n"
  "             (ast-has-free?"" (ast-lambda-body ast) x)))\n"
  "        ((ast-let?"" ast)\n"
  "         ;; If this let shadows x then we don't care about its body, but we do\n"
  "         ;; care about the bound form, which might contain a lambda using x.\n"
  "         ;; Otherwise we care about both the bound form and the body.\n"
  "         (if (eq?"" (ast-let-bound-name ast) x)\n"
  "             (ast-nonlocally-uses?"" (ast-let-bound-form ast) x)\n"
  "             (or (ast-nonlocally-uses?"" (ast-let-bound-form ast) x)\n"
  "                 (ast-nonlocally-uses?"" (ast-let-body ast) x))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (or (ast-nonlocally-uses?"" (ast-sequence-first ast) x)\n"
  "             (ast-nonlocally-uses?"" (ast-sequence-second ast) x)))))\n"
  "\n"
  ";;; An extension of ast-nonlocally-uses?"" to a list of ASTs.\n"
  "(define-constant (ast-nonlocally-uses?""-list asts x)\n"
  "  (and (non-null?"" asts)\n"
  "       (or (ast-nonlocally-uses?"" (car asts) x)\n"
  "           (ast-nonlocally-uses?""-list (cdr asts) x))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Boxed variables in an AST.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; This check is used to implement what David A. Kranz called \"Assignment\n"
  ";;; Conversion\" in his thesis about the Orbit compiler.\n"
  "\n"
  ";;; Check if a given local variable is at the same time *used* nonlocally\n"
  ";;; (assigned or not, it doesn't matter) and assigned (locally or not, it\n"
  ";;; doesn't matter): that is the case where a variable needs to be boxed.  Here,\n"
  ";;; like in the section above, non-locally means within a lambda contained,\n"
  ";;; directly or not, within the given AST.\n"
  ";;; We are looking at free occurrences of the variable, not at inner bindings\n"
  ";;; shadowing outer variables with the same name.\n"
  ";;;\n"
  ";;; A let block doesn't count for these purposes, as by itself a let within the\n"
  ";;; same procedure doesn't require boxing and I can keep a let-bound variable in\n"
  ";;; a register without any indirections, as long as assignments to the variable\n"
  ";;; don't need to be visible across lambdas.\n"
  ";;;\n"
  ";;; This is, of course, conservative: it would be possible to do better in some\n"
  ";;; cases, for example when a variable is assigned only locally and *before* the\n"
  ";;; lambda using it is reached.\n"
  "\n"
  ";;; Return non-#f iff the given variable needs to be boxed in the given AST.\n"
  "(define-constant (ast-requires-boxing-for?"" ast x)\n"
  "  (and (ast-nonlocally-uses?"" ast x)\n"
  "       (ast-has-assigned?"" ast x)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Non-locally assigned variables in an AST.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; FIXME: no, this idea is not what I need.  I need to check if a given local\n"
  ";;; is at the same time *used* nonlocally (assigned or not, it doesn't matter)\n"
  ";;; and assigned (locally or not, it doesn't matter).  That is the case where\n"
  ";;; a variable needs to be boxed.  Remove this section.\n"
  "\n"
  ";;; Check whether a variable is assigned non-locally in a lambda occurring\n"
  ";;; within the given AST.  For the purposes of this definition nested lets do\n"
  ";;; not count: only lambdas introduce the kind of non-locality we care about.\n"
  ";;;\n"
  ";;; Rationale: a set! on a non-local variable forces us to access the variable\n"
  ";;; locally thru a box, also pointed by any closure closing over the variable;\n"
  ";;; if, instead, a variable is accessed non-locally without being assigned in\n"
  ";;; the lambda, this indirection is not necessary.  The same way, we don't need\n"
  ";;; the box if the variable is assigned *locally* (including within a let, but\n"
  ";;; not within a lambda).\n"
  ";;; Compiled code relies on this, and I don't want to introduce boxes when it's\n"
  ";;; not needed.\n"
  "\n"
  ";;; Return non-#f iff any free occurrence of the given variable is set! (as per\n"
  ";;; ast-has-assigned?"") in a lambda syntactically contained within the given AST.\n"
  "(define-constant (ast-nonlocally-assigns?"" ast x)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         #f)\n"
  "        ((ast-variable?"" ast)\n"
  "         #f)\n"
  "        ((ast-define?"" ast)\n"
  "         ;; The defined variable is global, and therefore irrelevant here.\n"
  "         (ast-nonlocally-assigns?"" (ast-define-body ast) x))\n"
  "        ((ast-if?"" ast)\n"
  "         (or (ast-nonlocally-assigns?"" (ast-if-condition ast) x)\n"
  "             (ast-nonlocally-assigns?"" (ast-if-then ast) x)\n"
  "             (ast-nonlocally-assigns?"" (ast-if-else ast) x)))\n"
  "        ((ast-set!?"" ast)\n"
  "         ;; By itself this assignment, even if it were on x, is irrelevant\n"
  "         ;; because it's not within a lambda.  However the set! body might\n"
  "         ;; contain a lambda.\n"
  "         (ast-nonlocally-assigns?"" (ast-set!-body ast) x))\n"
  "        ((ast-while?"" ast)\n"
  "         (or (ast-nonlocally-assigns?"" (ast-while-guard ast) x)\n"
  "             (ast-nonlocally-assigns?"" (ast-while-body ast) x)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-nonlocally-assigns?""-list (ast-primitive-operands ast) x))\n"
  "        ((ast-call?"" ast)\n"
  "         (or (ast-nonlocally-assigns?"" (ast-call-operator ast) x)\n"
  "             (ast-nonlocally-assigns?""-list (ast-call-operands ast) x)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         ;; This is the interesting case: we search for assignment to *free*\n"
  "         ;; occurrences of x within the lambda -- including within lambdas\n"
  "         ;; nested within this one.\n"
  "         ;; If the lambda shadows x, then our own variable is not visible\n"
  "         ;; there and we know that it's not assigned non-locally.\n"
  "         ;; If the lambda doesn't shadow x, then we look for any assigned\n"
  "         ;; free occurrence within the lambda body.  Notice that the call\n"
  "         ;; examining the body doesn't recur to this function, but uses\n"
  "         ;; ast-has-assigned?"" since we have already crossed the one lambda\n"
  "         ;; boundary we were searching for: from this point the level of\n"
  "         ;; nesting of lambdas is no longer important.\n"
  "         (if (set-has?"" (ast-lambda-formals ast) x)\n"
  "             #f\n"
  "             (ast-has-assigned?"" (ast-lambda-body ast) x)))\n"
  "        ((ast-let?"" ast)\n"
  "         ;; If this let shadows x then we don't care about its body, but we do\n"
  "         ;; care about the bound form, which might contain a lambda assigning x.\n"
  "         ;; Otherwise we care about both the bound form and the body.\n"
  "         (if (eq?"" (ast-let-bound-name ast) x)\n"
  "             (ast-nonlocally-assigns?"" (ast-let-bound-form ast) x)\n"
  "             (or (ast-nonlocally-assigns?"" (ast-let-bound-form ast) x)\n"
  "                 (ast-nonlocally-assigns?"" (ast-let-body ast) x))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (or (ast-nonlocally-assigns?"" (ast-sequence-first ast) x)\n"
  "             (ast-nonlocally-assigns?"" (ast-sequence-second ast) x)))))\n"
  "\n"
  ";;; An extension of ast-nonlocally-assigns?"" to a list of ASTs.\n"
  "(define-constant (ast-nonlocally-assigns?""-list asts x)\n"
  "  (and (non-null?"" asts)\n"
  "       (or (ast-nonlocally-assigns?"" (car asts) x)\n"
  "           (ast-nonlocally-assigns?""-list (cdr asts) x))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; AST equality.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return non-#f iff two ASTs are syntactically equal.  This could of course be\n"
  ";;; made more accurate, for example by renaming bound variables in a consistent\n"
  ";;; way in the two ASTs.\n"
  ";;; Assume that a and b are both non-cyclic.\n"
  "(define-constant (ast-equal?"" a b)\n"
  "  (cond ((ast-literal?"" a)\n"
  "         (and (ast-literal?"" b)\n"
  "              (eq?"" (ast-literal-value a) (ast-literal-value b))))\n"
  "        ((ast-variable?"" a)\n"
  "         (and (ast-variable?"" b)\n"
  "              (eq?"" (ast-variable-name a) (ast-variable-name b))))\n"
  "        ((ast-define?"" a)\n"
  "         (and (ast-define?"" b)\n"
  "              (eq?"" (ast-define-name a) (ast-define-name b))\n"
  "              (ast-equal?"" (ast-define-body a) (ast-define-body b))))\n"
  "        ((ast-if?"" a)\n"
  "         (and (ast-if?"" b)\n"
  "              (ast-equal?"" (ast-if-condition a) (ast-if-condition b))\n"
  "              (ast-equal?"" (ast-if-then a) (ast-if-then b))\n"
  "              (ast-equal?"" (ast-if-else a) (ast-if-else b))))\n"
  "        ((ast-set!?"" a)\n"
  "         (and (ast-set!?"" b)\n"
  "              (eq?"" (ast-set!-name a) (ast-set!-name b))\n"
  "              (ast-equal?"" (ast-set!-body a) (ast-set!-body b))))\n"
  "        ((ast-while?"" a)\n"
  "         (and (ast-while?"" b)\n"
  "              (ast-equal?"" (ast-while-guard a) (ast-while-guard b))\n"
  "              (ast-equal?"" (ast-while-body a) (ast-while-body b))))\n"
  "        ((ast-primitive?"" a)\n"
  "         (and (ast-primitive?"" b)\n"
  "              (eq?"" (ast-primitive-operator a) (ast-primitive-operator b))\n"
  "              (ast-equal?""-list (ast-primitive-operands a) (ast-primitive-operands b))))\n"
  "        ((ast-call?"" a)\n"
  "         (and (ast-call?"" b)\n"
  "              (ast-equal?"" (ast-call-operator a) (ast-call-operator b))\n"
  "              (ast-equal?""-list (ast-call-operands a) (ast-call-operands b))))\n"
  "        ((ast-lambda?"" a)\n"
  "         (and (ast-lambda?"" b)\n"
  "              (eq?""-list (ast-lambda-formals a) (ast-lambda-formals b))\n"
  "              (ast-equal?"" (ast-lambda-body a) (ast-lambda-body b))))\n"
  "        ((ast-let?"" a)\n"
  "         (and (ast-let?"" b)\n"
  "              (eq?"" (ast-let-bound-name a) (ast-let-bound-name b))\n"
  "              (ast-equal?"" (ast-let-bound-form a) (ast-let-bound-form b))\n"
  "              (ast-equal?"" (ast-let-body a) (ast-let-body b))))\n"
  "        ((ast-sequence?"" a)\n"
  "         (and (ast-sequence?"" b)\n"
  "              (ast-equal?"" (ast-sequence-first a) (ast-sequence-first b))\n"
  "              (ast-equal?"" (ast-sequence-second a) (ast-sequence-second b))))))\n"
  "\n"
  ";;; An extension of ast-equal?"" to lists of ASTs.\n"
  ";;; Return non-#f iff the two given AST lists have syntactically equal elements\n"
  ";;; at the same positions.  Return #f if the lists have different lengths or if\n"
  ";;; any two elements at the same position are different.\n"
  "(define-constant (ast-equal?""-list as bs)\n"
  "  (cond ((null?"" as)\n"
  "         ;; Both empty lists, or different lengths.\n"
  "         (null?"" bs))\n"
  "        ((null?"" bs)\n"
  "         ;; Different lengths.\n"
  "         #f)\n"
  "        ((ast-equal?"" (car as) (car bs))\n"
  "         (ast-equal?""-list (cdr as) (cdr bs)))\n"
  "        (else\n"
  "         ;; Different first elements.\n"
  "         #f)))\n"
  "\n"
  ";;; A helper for ast-equal?"".  Return #t iff the two given non-cyclic lists of\n"
  ";;; eq?""-comparable values (used with symbols) are equal.\n"
  "(define-constant (eq?""-list as bs)\n"
  "  (cond ((null?"" as)\n"
  "         ;; Both empty lists, or different lengths.\n"
  "         (null?"" bs))\n"
  "        ((null?"" bs)\n"
  "         ;; Different lengths.\n"
  "         #f)\n"
  "        ((eq?"" (car as) (car bs))\n"
  "         (eq?""-list (cdr as) (cdr bs)))\n"
  "        (else\n"
  "         ;; Different first elements.\n"
  "         #f)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; AST alpha-conversion.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return an AST equal to the given one, except that every bound variable\n"
  ";;; has been consistently renamed to a fresh identifier.\n"
  "(define-constant (ast-alpha-convert ast)\n"
  "  (ast-alpha-convert-with ast ()))\n"
  "\n"
  ";;; A helper procedure for ast-alpha-convert, keeping track of which free\n"
  ";;; variable variable is to be replaced with which new variable.  Recursive\n"
  ";;; calls will build new alists extending the given one, with a fresh new\n"
  ";;; variable associated to each inner bound variable.\n"
  "(define-constant (ast-alpha-convert-with ast alist)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         ast)\n"
  "        ((ast-variable?"" ast)\n"
  "         (let ((pair (assq (ast-variable-name ast) alist)))\n"
  "           (if pair\n"
  "               (ast-variable (cdr pair))\n"
  "               ast)))\n"
  "        ((ast-define?"" ast)\n"
  "         ;; Do not rename globally bound variables.\n"
  "         (ast-define (ast-define-name ast)\n"
  "                     (ast-alpha-convert-with (ast-define-body ast) alist)))\n"
  "        ((ast-if?"" ast)\n"
  "         (ast-if (ast-alpha-convert-with (ast-if-condition ast) alist)\n"
  "                 (ast-alpha-convert-with (ast-if-then ast) alist)\n"
  "                 (ast-alpha-convert-with (ast-if-else ast) alist)))\n"
  "        ((ast-set!?"" ast)\n"
  "         (let* ((old-name (ast-set!-name ast))\n"
  "                (pair (assq old-name alist))\n"
  "                (new-name (if pair (cdr pair) old-name)))\n"
  "           (ast-set! new-name\n"
  "                     (ast-alpha-convert-with (ast-set!-body ast) alist))))\n"
  "        ((ast-while?"" ast)\n"
  "         (ast-while (ast-alpha-convert-with (ast-while-guard ast) alist)\n"
  "                    (ast-alpha-convert-with (ast-while-body ast) alist)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-primitive (ast-primitive-operator ast)\n"
  "                        (ast-alpha-convert-with-list\n"
  "                            (ast-primitive-operands ast)\n"
  "                            alist)))\n"
  "        ((ast-call?"" ast)\n"
  "         (ast-call (ast-alpha-convert-with (ast-call-operator ast) alist)\n"
  "                   (ast-alpha-convert-with-list (ast-call-operands ast)\n"
  "                                                alist)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (let* ((old-formals (ast-lambda-formals ast))\n"
  "                (new-formals (map (lambda (useless) (gensym)) old-formals))\n"
  "                (new-bindings (zip-reversed old-formals new-formals))\n"
  "                (new-alist (append! new-bindings alist)))\n"
  "           (ast-lambda new-formals\n"
  "                       (ast-alpha-convert-with (ast-lambda-body ast)\n"
  "                                               new-alist))))\n"
  "        ((ast-let?"" ast)\n"
  "         (let* ((old-bound-name (ast-let-bound-name ast))\n"
  "                (new-bound-name (gensym))\n"
  "                (new-alist (cons (cons old-bound-name new-bound-name) alist)))\n"
  "           (ast-let new-bound-name\n"
  "                    (ast-alpha-convert-with (ast-let-bound-form ast)\n"
  "                                            alist) ;; Important: not new-alist\n"
  "                    (ast-alpha-convert-with (ast-let-body ast)\n"
  "                                            new-alist))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (ast-sequence (ast-alpha-convert-with (ast-sequence-first ast)\n"
  "                                               alist)\n"
  "                       (ast-alpha-convert-with (ast-sequence-second ast)\n"
  "                                               alist)))))\n"
  "\n"
  ";;; An extension of ast-alpha-convert-with to a list of ASTs: return the list\n"
  ";;; of rewriten ASTs in order.\n"
  "(define-constant (ast-alpha-convert-with-list asts alist)\n"
  "  (map (lambda (ast) (ast-alpha-convert-with ast alist))\n"
  "       asts))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Global constant folding.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return a copy of the given AST where every free occurrence of current global\n"
  ";;; constants in replaced with its global value as a literal.  The additional\n"
  ";;; argument is a set-of-list of the currently bound variables; of course bound\n"
  ";;; variables just happening to share a name with a global constant must not be\n"
  ";;; replaced.\n"
  "(define-constant (ast-global-fold ast bounds)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         ast)\n"
  "        ((ast-variable?"" ast)\n"
  "         (let ((name (ast-variable-name ast)))\n"
  "           (if (and (not (set-has?"" bounds name))\n"
  "                    (defined?"" name)\n"
  "                    (constant?"" name))\n"
  "               (ast-literal (symbol-global name))\n"
  "               ast)))\n"
  "        ((ast-define?"" ast)\n"
  "         (ast-define (ast-define-name ast)\n"
  "                     (ast-global-fold (ast-define-body ast) bounds)))\n"
  "        ((ast-if?"" ast)\n"
  "         (ast-if (ast-global-fold (ast-if-condition ast) bounds)\n"
  "                 (ast-global-fold (ast-if-then ast) bounds)\n"
  "                 (ast-global-fold (ast-if-else ast) bounds)))\n"
  "        ((ast-set!?"" ast)\n"
  "         (ast-set! (ast-set!-name ast)\n"
  "                   (ast-global-fold (ast-set!-body ast) bounds)))\n"
  "        ((ast-while?"" ast)\n"
  "         (ast-while (ast-global-fold (ast-while-guard ast) bounds)\n"
  "                    (ast-global-fold (ast-while-body ast) bounds)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-primitive (ast-primitive-operator ast)\n"
  "                        (ast-global-fold-list (ast-primitive-operands ast)\n"
  "                                              bounds)))\n"
  "        ((ast-call?"" ast)\n"
  "         (ast-call (ast-global-fold (ast-call-operator ast) bounds)\n"
  "                   (ast-global-fold-list (ast-call-operands ast)\n"
  "                                         bounds)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (let ((formals (ast-lambda-formals ast)))\n"
  "           (ast-lambda formals\n"
  "                       (ast-global-fold (ast-lambda-body ast)\n"
  "                                        (set-unite formals bounds)))))\n"
  "        ((ast-let?"" ast)\n"
  "         (let* ((bound-name (ast-let-bound-name ast))\n"
  "                (old-bound-form (ast-let-bound-form ast))\n"
  "                (new-bound-form (ast-global-fold old-bound-form bounds))\n"
  "                (old-body (ast-let-body ast))\n"
  "                (new-body (ast-global-fold old-body\n"
  "                                           (set-with bounds bound-name))))\n"
  "           (ast-let bound-name\n"
  "                    new-bound-form\n"
  "                    new-body)))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (ast-sequence (ast-global-fold (ast-sequence-first ast) bounds)\n"
  "                       (ast-global-fold (ast-sequence-second ast)\n"
  "                                        bounds)))))\n"
  "\n"
  ";;; An extension of ast-global-fold to a list of ASTs: return the list\n"
  ";;; of rewriten ASTs in order.\n"
  "(define-constant (ast-global-fold-list asts bounds)\n"
  "  (map (lambda (ast) (ast-global-fold ast bounds))\n"
  "       asts))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Effect analysis.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; FIXME: it would be useful to define a notion similar to this but weaker, not\n"
  ";;; considering allocation an effect.  This would let me remove some useless\n"
  ";;; allocations.\n"
  "\n"
  ";;; Return non-#f iff the evaluation of the given may have effects, in an\n"
  ";;; environment where with the given set-as-list of variables are bound.\n"
  ";;;\n"
  ";;; The analysis is, of course, partial: a #f result means that the AST is\n"
  ";;; guaranteed not to have effects.  A non-#f result means that the AST\n"
  ";;; evaluation *may* have effects, which is meant to direct optimizers to err on\n"
  ";;; the safe side.\n"
  ";;; An analysis more precise than this is certainly possible, but catching every\n"
  ";;; possible case of effects would require solving the Halting Problem.\n"
  ";;;\n"
  ";;; Notice that accessing a variable which is not bound and is not a constant\n"
  ";;; is considered an effectful operation: the variable may be undefined as a\n"
  ";;; global at evaluation time, which would cause a runtime error -- a visible\n"
  ";;; effect.\n"
  ";;; Any other error, including type errors, is also an effect.\n"
  ";;; Heap allocation is an effect (allocations cannot in general be merged\n"
  ";;;   without changing the program semantics).\n"
  ";;; Non-termination is also an effect.\n"
  "(define-constant (ast-effectful?"" ast bounds)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         #f)\n"
  "        ((ast-variable?"" ast)\n"
  "         (cond ((set-has?"" bounds (ast-variable-name ast))\n"
  "                ;; Reading a bound variable has no effects.\n"
  "                #f)\n"
  "               ((constant?"" (ast-variable-name ast))\n"
  "                ;; Reading a global constant has no effects.\n"
  "                #f)\n"
  "               (else\n"
  "                ;; Reading a global non-constant may fail, which counts as an\n"
  "                ;; effect.\n"
  "                #t)))\n"
  "        ((ast-define?"" ast)\n"
  "         ;; Global definitions can have effects.\n"
  "         #t)\n"
  "        ((ast-if?"" ast)\n"
  "         (or (ast-effectful?"" (ast-if-condition ast) bounds)\n"
  "             (ast-effectful?"" (ast-if-then ast) bounds)\n"
  "             (ast-effectful?"" (ast-if-else ast) bounds)))\n"
  "        ((ast-set!?"" ast)\n"
  "         ;; Assignments can have effects, and usually do.\n"
  "         #t)\n"
  "        ((ast-while?"" ast)\n"
  "         ;; A while loop can have effects even if its guard and body are both\n"
  "         ;; non-effectful, since non-termination is an effect.\n"
  "         (let ((guard (ast-while-guard ast)))\n"
  "           ;; The only case where we bother returning a more precise result is a\n"
  "           ;; while loop with the constant #f as guard.\n"
  "           (if (and (ast-literal?"" guard)\n"
  "                    (not (ast-literal-value guard)))\n"
  "               #f\n"
  "               ;; The guard is not #f.  Consider the loop effectful.\n"
  "               #t)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         ;; Some primitives are known to be non-effectful, but all of their\n"
  "         ;; arguments must be non-effectful as well for the entire AST to be\n"
  "         ;; non-effectful.\n"
  "         ;; It would be possible to be more precise and check for types in\n"
  "         ;; some cases, where arguments are known; this would be useful for\n"
  "         ;; arithmetic.\n"
  "         (or (primitive-effectful?"" (ast-primitive-operator ast))\n"
  "             (ast-effectful?""-list (ast-primitive-operands ast)\n"
  "                                  bounds)))\n"
  "        ((ast-call?"" ast)\n"
  "         ;; It's not trivial to return a more precise result here without\n"
  "         ;; visiting a call graph of constant callees to be recursively\n"
  "         ;; analyzed, keeping termination into account.  Right now I consider\n"
  "         ;; any call effectful.\n"
  "         #t)\n"
  "        ((ast-lambda?"" ast)\n"
  "         ;; Making a new closure is effectful, as an allocation operation.\n"
  "         #t)\n"
  "        ((ast-let?"" ast)\n"
  "         (or (ast-effectful?"" (ast-let-bound-form ast)\n"
  "                             bounds)\n"
  "             (ast-effectful?"" (ast-let-body ast)\n"
  "                             (set-with bounds\n"
  "                                       (ast-let-bound-name ast)))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (or (ast-effectful?"" (ast-sequence-first ast) bounds)\n"
  "             (ast-effectful?"" (ast-sequence-second ast) bounds)))))\n"
  "\n"
  ";;; An extension of ast-effectful?"" to a list of ASTs: return #f iff\n"
  ";;; *all* the ASTs in the list are known to be non-effectful.\n"
  "(define-constant (ast-effectful?""-list asts bounds)\n"
  "  (cond ((null?"" asts)\n"
  "         #f)\n"
  "        ((ast-effectful?"" (car asts) bounds)\n"
  "         #t)\n"
  "        (else\n"
  "         (ast-effectful?""-list (cdr asts) bounds))))\n"
  "\n"
  ";;; A set-as-list of non-effectful primitives.  FIXME: add a\n"
  ";;; primitive-effectful?"" primitive and use it, instead of this.\n"
  ";;;\n"
  ";;; Notice that any primitives having type requirements on its arguments\n"
  ";;; may fail, and is therefore effectful.  A primitive always returning\n"
  ";;; a result given any argument is non-effectful.\n"
  ";;; Type checking (for example primitive-null?"") is therefore non-effectful,\n"
  ";;; but case checking (for example primitive-ast-variable?"" or\n"
  ";;; primitive-zero?"" , which fails on non-numbers) is effectful.\n"
  ";;;\n"
  ";;; Allocation primitives are effectful: primitive uses cannot be eliminated\n"
  ";;; without changing the program semantics, in the presence of side effects.\n"
  ";;; This makes primitive-cons and primitive-gensym effectful.\n"
  ";;;\n"
  ";;; Nullary primitives depending on global modifiable state, such as\n"
  ";;; primitive-interned-symbols are effectful: their result may be different at a\n"
  ";;; later time when the AST is actually executed.\n"
  "(define-constant non-effectful-primitives\n"
  "  (set ;; Type-checking primitives may return #f, but never fail.\n"
  "       primitive-fixnum?""\n"
  "       primitive-character?""\n"
  "       primitive-null?""\n"
  "       primitive-non-null?""\n"
  "       primitive-eof?""\n"
  "       primitive-boolean?""\n"
  "       primitive-nothing?""\n"
  "       primitive-undefined?""\n"
  "       primitive-symbol?""\n"
  "       primitive-non-symbol?""\n"
  "       primitive-cons?""\n"
  "       primitive-non-cons?""\n"
  "       primitive-box?""\n"
  "       primitive-closure?""\n"
  "       primitive-primitive?""\n"
  "       primitive-ast?""\n"
  "       primitive-macro?""\n"
  "       primitive-vector?""\n"
  "       ;; Equality comparisons never fail (but maginitude comparisons may).\n"
  "       primitive-eq?""\n"
  "       primitive-not-eq?""\n"
  "       ;; Logical negation and canonicalization accept a generalized boolean,\n"
  "       ;; and therefore never fail.\n"
  "       primitive-not\n"
  "       primitive-boolean-canonicalize))\n"
  "\n"
  ";;; Any primitive not in the set-as-list above is considered to be effectful.\n"
  "(define-constant (primitive-effectful?"" primitive)\n"
  "  (not (set-has?"" non-effectful-primitives primitive)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Instantiation.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return a copy of the given AST where every free occurrence of the given\n"
  ";;; variable is replaced with the given AST.  Error out if a free occurrence\n"
  ";;; of the variable is assigned, in which case instantiation would be invalid.\n"
  ";;; Of course there are other cases in which instantiation would yield an AST\n"
  ";;; not equivalent to the original: this is not checked for.\n"
  "(define-constant (ast-instantiate ast x r)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         ast)\n"
  "        ((ast-variable?"" ast)\n"
  "         (if (eq?"" (ast-variable-name ast) x)\n"
  "             r\n"
  "             ast))\n"
  "        ((ast-define?"" ast)\n"
  "         ;; Do not rename globally bound variables.\n"
  "         (ast-define (ast-define-name ast)\n"
  "                     (ast-instantiate (ast-define-body ast) x r)))\n"
  "        ((ast-if?"" ast)\n"
  "         (ast-if (ast-instantiate (ast-if-condition ast) x r)\n"
  "                 (ast-instantiate (ast-if-then ast) x r)\n"
  "                 (ast-instantiate (ast-if-else ast) x r)))\n"
  "        ((ast-set!?"" ast)\n"
  "         (let ((name (ast-set!-name ast)))\n"
  "           (when (eq?"" name x)\n"
  "             (error `(instantiating assigned variable ,x in ,ast)))\n"
  "           (ast-set! name\n"
  "                     (ast-instantiate (ast-set!-body ast) x r))))\n"
  "        ((ast-while?"" ast)\n"
  "         (ast-while (ast-instantiate (ast-while-guard ast) x r)\n"
  "                    (ast-instantiate (ast-while-body ast) x r)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-primitive (ast-primitive-operator ast)\n"
  "                        (ast-instantiate-list (ast-primitive-operands ast) x r)))\n"
  "        ((ast-call?"" ast)\n"
  "         (ast-call (ast-instantiate (ast-call-operator ast) x r)\n"
  "                   (ast-instantiate-list (ast-call-operands ast) x r)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (let ((formals (ast-lambda-formals ast)))\n"
  "           (if (set-has?"" formals x)\n"
  "               ast ;; x occurs bound: don't touch its uses.\n"
  "               (ast-lambda formals\n"
  "                           (ast-instantiate (ast-lambda-body ast) x r)))))\n"
  "        ((ast-let?"" ast)\n"
  "         ;; Always instantiate in the bound form.  Instantiate in the body\n"
  "         ;; only if the let variable is not the one we are replacing.  Don't\n"
  "         ;; rename the bound variable.\n"
  "         (let* ((bound-name (ast-let-bound-name ast))\n"
  "                (old-bound-form (ast-let-bound-form ast))\n"
  "                (new-bound-form (ast-instantiate old-bound-form x r))\n"
  "                (old-body (ast-let-body ast))\n"
  "                (new-body (if (eq?"" bound-name x)\n"
  "                              old-body\n"
  "                              (ast-instantiate old-body x r))))\n"
  "           (ast-let bound-name\n"
  "                    new-bound-form\n"
  "                    new-body)))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (ast-sequence (ast-instantiate (ast-sequence-first ast) x r)\n"
  "                       (ast-instantiate (ast-sequence-second ast) x r)))))\n"
  "\n"
  ";;; An extension of ast-instantiate to a list of ASTs: return the list\n"
  ";;; of rewriten ASTs in order.\n"
  "(define-constant (ast-instantiate-list asts x r)\n"
  "  (map (lambda (ast) (ast-instantiate ast x r))\n"
  "       asts))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; AST leafness.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return non-#f iff the given AST is a leaf expression.\n"
  "(define-constant (ast-leaf?"" ast)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         #t)\n"
  "        ((ast-variable?"" ast)\n"
  "         #t)\n"
  "        ((ast-define?"" ast)\n"
  "         (ast-leaf?"" (ast-define-body ast)))\n"
  "        ((ast-if?"" ast)\n"
  "         (and (ast-leaf?"" (ast-if-condition ast))\n"
  "              (ast-leaf?"" (ast-if-then ast))\n"
  "              (ast-leaf?"" (ast-if-else ast))))\n"
  "        ((ast-set!?"" ast)\n"
  "         (ast-leaf?"" (ast-set!-body ast)))\n"
  "        ((ast-while?"" ast)\n"
  "         (and (ast-leaf?"" (ast-while-guard ast))\n"
  "              (ast-leaf?"" (ast-while-body ast))))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-leaf?""-list (ast-primitive-operands ast)))\n"
  "        ((ast-call?"" ast)\n"
  "         #f)\n"
  "        ((ast-lambda?"" ast)\n"
  "         (ast-leaf?"" (ast-lambda-body ast)))\n"
  "        ((ast-let?"" ast)\n"
  "         (and (ast-leaf?"" (ast-let-bound-form ast))\n"
  "              (ast-leaf?"" (ast-let-body ast))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (and (ast-leaf?"" (ast-sequence-first ast))\n"
  "              (ast-leaf?"" (ast-sequence-second ast))))))\n"
  "\n"
  ";;; An extension of ast-leaf?"" to a list of ASTs: return non-#f iff the ASTs in\n"
  ";;; the given list are all leaves.\n"
  "(define-constant (ast-leaf?""-list asts)\n"
  "  (cond ((null?"" asts)\n"
  "         #t)\n"
  "        ((ast-leaf?"" (car asts))\n"
  "         (ast-leaf?""-list (cdr asts)))\n"
  "        (else\n"
  "         #f)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; AST call simplification.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; The transformations here rely on the caller being alpha-converted already:\n"
  ";;; any inlining might result in nonglobal capture otherwise.\n"
  "\n"
  ";;; A call where the operator is a closure literal (usually obtained by a\n"
  ";;; previous optimization) can be easily rewritten into a let binding each\n"
  ";;; formal as a local variable and having the lambda body as the let body,\n"
  ";;; as long as the closure environment is empty.\n"
  ";;; Some optimizations can probably be performed even with non-empty\n"
  ";;; closure environments but this is not implemented yet, as the way\n"
  ";;; environments are represented will change in the future.\n"
  ";;;\n"
  ";;; Most of the let forms introduced by this rewrite can be optimized away\n"
  ";;; in a later pass.\n"
  "\n"
  ";;; Return a rewritten call having the given closure as the original (literal)\n"
  ";;; operator, and the ASTs in the given list as operands.\n"
  "(define-constant (ast-simplify-known-closure-call-helper closure actuals)\n"
  "  ;; FIXME: would it be a problem for termination if I used ast-optimize instead\n"
  "  ;; of ast-simplify-known-closure-call-helper in recursive calls?""  Would it\n"
  "  ;; help?""\n"
  "  (let ((environment (interpreted-closure-environment closure))\n"
  "        (formals (interpreted-closure-formals closure))\n"
  "        (body (interpreted-closure-body closure)))\n"
  "    (cond ((non-null?"" environment)\n"
  "           ;; We currently don't rewrite if the environment is non-empty.\n"
  "           (ast-call (ast-literal closure) actuals))\n"
  "          ((<> (length formals) (length actuals))\n"
  "           ;; This call will fail if reached: don't rewrite it.\n"
  "           ;; FIXME: warn in a cleaner way.\n"
  "           (display `(warning: invalid in-arity ,(length actuals)\n"
  "                               for call to in-arity ,(length formals)\n"
  "                               ,closure\n"
  "                               with actuals ,actuals))\n"
  "           (newline)\n"
  "           (ast-call (ast-literal closure) actuals))\n"
  "          ((closure-wrapper?"" closure)\n"
  "           ;; Wrapper calls are easy to rewrite into a particularly efficient\n"
  "           ;; AST.  This rewrite could be subsumed by others not yet\n"
  "           ;; implemented, but this is very common and important to have from\n"
  "           ;; the get go.\n"
  "           (ast-rewrite-wrapper-call body actuals))\n"
  "          (else\n"
  "           ;; The environment is empty, and the argument number is correct:\n"
  "           ;; rewrite into nested lets binding the closure formals to the call\n"
  "           ;; actuals, and then evaluating the closure body.  alpha-convert the\n"
  "           ;; closure content to avoid conflicts with local variables in the\n"
  "           ;; caller.\n"
  "           ;; (display `(inlining call to ,closure)) (newline)\n"
  "           (let* ((new-formals (map (lambda (useless) (gensym)) formals))\n"
  "                  (alist (zip formals new-formals))\n"
  "                  (new-body (ast-alpha-convert-with body alist)))\n"
  "             (ast-nested-let new-formals actuals new-body))))))\n"
  "\n"
  ";;; I define a \"wrapper\" to be an empty-environment closure with n formals,\n"
  ";;; whose entire body consists of either:\n"
  ";;; (a) a primitive with the formals as its operands, all used, in the same\n"
  ";;;     order;\n"
  ";;; (b) a call with a leaf operator where no formal occurs free in the operator,\n"
  ";;;     and the operands are like in the previous case.\n"
  ";;; Notice that the second case has no restriction on operator effects: even in\n"
  ";;; rewritten form the order of effects doesn't change.\n"
  ";;;\n"
  ";;; The leafness restriction is unfortunate, but is an easy way to avoid\n"
  ";;; infinite expansion in case the operator contains recursive calls to itself\n"
  ";;; or to the closure containing it.\n"
  ";;;\n"
  ";;; Wrappers are common and calls to them can be rewritten efficiently.  This\n"
  ";;; is an easy check to make, which may be subsumed by other rewrites -- however\n"
  ";;; those rewrites, still to implement, are much more complex.\n"
  ";;;\n"
  ";;; Notice that wrapper closures by definition have a leaf body and an empty\n"
  ";;; environment, so they are always considered for inlining.\n"
  "(define-constant (closure-wrapper?"" closure)\n"
  "  (let ((environment (interpreted-closure-environment closure))\n"
  "        (formals (interpreted-closure-formals closure))\n"
  "        (body (interpreted-closure-body closure)))\n"
  "    (cond ((non-null?"" environment)\n"
  "           ;; This could be generalized, but is probably not worth the trouble\n"
  "           ;; yet: right now we refuse to consider a closure to be a wrapper if\n"
  "           ;; it has any nonlocals.\n"
  "           #f)\n"
  "          ((and (ast-primitive?"" body)\n"
  "                (ast-wrapper-arguments?"" formals (ast-primitive-operands body)))\n"
  "           ;; The primitive case as defined above.\n"
  "           #t)\n"
  "          ((and (ast-call?"" body)\n"
  "                (ast-leaf?"" (ast-call-operator body))\n"
  "                (for-all?"" (lambda (formal)\n"
  "                            (not (ast-has-free?"" (ast-call-operator body)\n"
  "                                                formal)))\n"
  "                          formals)\n"
  "                ;; No restrictions on operator effects here.  On purpose.\n"
  "                (ast-wrapper-arguments?"" formals (ast-call-operands body)))\n"
  "           ;; The call case as defined above.\n"
  "           #t)\n"
  "          (else\n"
  "           ;; In any other case, the body is not a wrapper.\n"
  "           #f))))\n"
  "\n"
  ";;; A helper for closure-wrapper?"".\n"
  ";;; Return non-#f iff the given actuals respect the wrapper definition above,\n"
  ";;; agreeing with the given formals.\n"
  "(define-constant (ast-wrapper-arguments?"" formals actuals)\n"
  "  (cond ((null?"" formals)\n"
  "         ;; If both lists are empty the two in-arities agree.\n"
  "         (null?"" actuals))\n"
  "        ((null?"" actuals)\n"
  "         ;; Different in-arities.\n"
  "         #f)\n"
  "        ((and (ast-variable?"" (car actuals))\n"
  "              (eq?"" (car formals)\n"
  "                   (ast-variable-name (car actuals))))\n"
  "         (ast-wrapper-arguments?"" (cdr formals) (cdr actuals)))\n"
  "        (else\n"
  "         ;; Non-variable actual, or variable not matching the\n"
  "         ;; formal in its position.\n"
  "         #f)))\n"
  "\n"
  ";;; Return non-#f iff the argument is an interpreted closure satisfying the (a)\n"
  ";;; case of the definition above.  This is convenient to use below in the\n"
  ";;; compiler, as \"primitive wrappers\" can be compiled to efficient code.\n"
  "(define-constant (closure-primitive-wrapper?"" thing)\n"
  "  (if (not (interpreted-closure?"" thing))\n"
  "      #f\n"
  "      (let ((environment (interpreted-closure-environment thing))\n"
  "            (formals (interpreted-closure-formals thing))\n"
  "            (body (interpreted-closure-body thing)))\n"
  "        (and (ast-primitive?"" body)\n"
  "             (ast-wrapper-arguments?"" formals (ast-primitive-operands body))))))\n"
  "\n"
  ";;; Return a rewritten a wrapper call.  We assume that the body is a wrapper,\n"
  ";;; and that the actuals respect the wrapper in-arity; notice that we even\n"
  ";;; ignore the operator formal names.\n"
  "(define-constant (ast-rewrite-wrapper-call body actuals)\n"
  "  (cond ((ast-primitive?"" body)\n"
  "         ;; We don't need any let, or even alpha-conversion: any call to a\n"
  "         ;; primitive wrapper with the correct in-arity can be rewritten to\n"
  "         ;; [primitive p . actuals], as long as the actuals are not reordered;\n"
  "         ;; this is correct even with effects.\n"
  "         (ast-primitive (ast-primitive-operator body) actuals))\n"
  "        ((ast-call?"" body)\n"
  "         ;; As long as this is a procedure wrapper we can do like in the\n"
  "         ;; primitive case.  This does require the operator not to have effects,\n"
  "         ;; but that has been checked already by this procedure's caller.\n"
  "         (ast-call (ast-call-operator body) actuals))\n"
  "        (else\n"
  "         ;; This shouldn't happen.\n"
  "         (error `(ast-rewrite-wrapper-call: operator ,body not a\n"
  "                                            wrapper body)))))\n"
  "\n"
  "\n"
  ";;; Given a list of bound variables, a list of actuals and a body, build nested\n"
  ";;; let ASTs, evaluating the actuals left-to-right.  This is similar to a let*\n"
  ";;; in Lisp, with a different syntax.  Assume that the formals and the actual\n"
  ";;; ASTs have the same length.\n"
  ";;; We can afford simple nested bindings here since procedure formals are\n"
  ";;; guaranteed to be all different.\n"
  "(define-constant (ast-nested-let formals actual-asts body-ast)\n"
  "  (if (null?"" formals)\n"
  "      body-ast\n"
  "      (ast-let (car formals) (car actual-asts)\n"
  "               (ast-nested-let (cdr formals) (cdr actual-asts)\n"
  "                               body-ast))))\n"
  "\n"
  ";;; Return the rewritten form of a call to the lambda operator shaped like\n"
  ";;; ((lambda FORMALS BODY-AST) . ACTUALS-ASTS) , using nested let forms.\n"
  "(define-constant (ast-simplify-lambda-call formals actual-asts body-ast)\n"
  "  (if (<> (length formals) (length actual-asts))\n"
  "      ;; Don't rewrite in case of arity mismatch: the code will fail\n"
  "      ;; if reached.\n"
  "      (begin\n"
  "        ;; FIXME: warn more cleanly.\n"
  "        (display `(WARNING: in-arity mismatch in call to lambda\n"
  "                            with formals ,formals and body ,body-ast))\n"
  "        (newline)\n"
  "        (ast-call (ast-lambda formals body-ast) actual-asts))\n"
  "      ;; Generate two layers of nested lets, the outer layer binding fresh\n"
  "      ;; identifiers to actuals, the inner layer binding the original lambda\n"
  "      ;; formals to the fresh identifiers of the outer layer.  This may be\n"
  "      ;; needed to avoid capture, and is the same trick used to rewrite\n"
  "      ;; one Lisp-style multiple-binding let into nested AST-style\n"
  "      ;; one-binding lets.\n"
  "      (let* ((fresh-variables (map (lambda (useless) (gensym)) formals))\n"
  "             (fresh-variable-asts (map ast-variable fresh-variables)))\n"
  "        (ast-nested-let (append fresh-variables formals)\n"
  "                        (append actual-asts fresh-variable-asts)\n"
  "                        body-ast))))\n"
  "\n"
  ";;; Return a copy of the given AST where calls to closure literals are\n"
  ";;; rewritten into let forms where possible.  The AST is assumed to be\n"
  ";;; already alpha-converted.\n"
  "(define-constant (ast-simplify-calls ast)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         ast)\n"
  "        ((ast-variable?"" ast)\n"
  "         ast)\n"
  "        ((ast-define?"" ast)\n"
  "         (ast-define (ast-define-name ast)\n"
  "                     (ast-simplify-calls (ast-define-body ast))))\n"
  "        ((ast-if?"" ast)\n"
  "         (ast-if (ast-simplify-calls (ast-if-condition ast))\n"
  "                 (ast-simplify-calls (ast-if-then ast))\n"
  "                 (ast-simplify-calls (ast-if-else ast))))\n"
  "        ((ast-set!?"" ast)\n"
  "         (ast-set! (ast-set!-name ast)\n"
  "                   (ast-simplify-calls (ast-set!-body ast))))\n"
  "        ((ast-while?"" ast)\n"
  "         (ast-while (ast-simplify-calls (ast-while-guard ast))\n"
  "                    (ast-simplify-calls (ast-while-body ast))))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-primitive (ast-primitive-operator ast)\n"
  "                        (ast-simplify-calls-list (ast-primitive-operands ast))))\n"
  "        ((ast-call?"" ast)\n"
  "         (let (;; Simplifying the operator seems perfunctory if we consider the\n"
  "               ;; kind of ASTs this procedure is used on.  Anyway it might be\n"
  "               ;; profitable in the future, with ASTs of a different shape.\n"
  "               (simplified-operator\n"
  "                (ast-simplify-calls (ast-call-operator ast)))\n"
  "               ;; Simplifying the operands is always reasonable, instead: they\n"
  "               ;; may contain calls.\n"
  "               (simplified-operands\n"
  "                (ast-simplify-calls-list (ast-call-operands ast))))\n"
  "           (cond ((ast-lambda?"" simplified-operator)\n"
  "                  ;;; This can always be rewritten into nested let forms, as\n"
  "                  ;;; long as the arity matches.\n"
  "                  (ast-simplify-lambda-call (ast-lambda-formals\n"
  "                                             simplified-operator)\n"
  "                                            simplified-operands\n"
  "                                            (ast-lambda-body\n"
  "                                             simplified-operator)))\n"
  "                 ;; FIXME: support compiled closures as well, somehow.\n"
  "                 ((and (ast-literal?"" simplified-operator)\n"
  "                       (interpreted-closure?"" (ast-literal-value simplified-operator))\n"
  "                       (or ;; This may be too aggressive: I currently inline\n"
  "                           ;; every call to a known leaf closure, independently\n"
  "                           ;; from the body size.\n"
  "                           (ast-leaf?"" (interpreted-closure-body (ast-literal-value\n"
  "                                                                 simplified-operator)))\n"
  "                           ;; In order to make this not too aggressive as well,\n"
  "                           ;; I require procedure wrapper bodies to be leaves;\n"
  "                           ;; otherwise a procedure wrapper which is recursive\n"
  "                           ;; on the operator side would cause an infinite\n"
  "                           ;; expansion here.\n"
  "                           (closure-wrapper?"" (ast-literal-value\n"
  "                                              simplified-operator))))\n"
  "                  (ast-simplify-known-closure-call-helper (ast-literal-value\n"
  "                                                           simplified-operator)\n"
  "                                                          simplified-operands))\n"
  "                 (else\n"
  "                  (ast-call simplified-operator simplified-operands)))))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (ast-lambda (ast-lambda-formals ast)\n"
  "                     (ast-simplify-calls (ast-lambda-body ast))))\n"
  "        ((ast-let?"" ast)\n"
  "         (ast-let (ast-let-bound-name ast)\n"
  "                  (ast-simplify-calls (ast-let-bound-form ast))\n"
  "                  (ast-simplify-calls (ast-let-body ast))))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (ast-sequence (ast-simplify-calls (ast-sequence-first ast))\n"
  "                       (ast-simplify-calls (ast-sequence-second ast))))))\n"
  "\n"
  ";;; An extension of ast-simplify-calls to a list of ASTs: return the list\n"
  ";;; of rewriten ASTs in order.\n"
  "(define-constant (ast-simplify-calls-list asts)\n"
  "  (map ast-simplify-calls asts))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; AST optimization.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return an equivalent rewritten version of the given AST, which is assumed to\n"
  ";;; be alpha-converted, knowing that the given set-of-list of variables is\n"
  ";;; bound.\n"
  ";;; The most important optimizations are for the let case, which uses the helper\n"
  ";;; below.\n"
  "(define-constant (ast-optimize-helper ast bounds)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         ast)\n"
  "        ((ast-variable?"" ast)\n"
  "         ast)\n"
  "        ((ast-define?"" ast)\n"
  "         (ast-define (ast-define-name ast)\n"
  "                     (ast-optimize-helper (ast-define-body ast) bounds)))\n"
  "        ((ast-if?"" ast)\n"
  "         (ast-optimize-if (ast-if-condition ast)\n"
  "                          (ast-if-then ast)\n"
  "                          (ast-if-else ast)\n"
  "                          bounds))\n"
  "        ((ast-set!?"" ast)\n"
  "         (ast-optimize-set! (ast-set!-name ast)\n"
  "                            (ast-optimize-helper (ast-set!-body ast) bounds)\n"
  "                            bounds))\n"
  "        ((ast-while?"" ast)\n"
  "         (ast-optimize-while (ast-optimize-helper (ast-while-guard ast)\n"
  "                                                  bounds)\n"
  "                             (ast-while-body ast)\n"
  "                             bounds))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (ast-optimize-primitive (ast-primitive-operator ast)\n"
  "                                 (ast-optimize-helper-list\n"
  "                                     (ast-primitive-operands ast)\n"
  "                                     bounds)))\n"
  "        ((ast-call?"" ast)\n"
  "         (ast-call (ast-optimize-helper (ast-call-operator ast) bounds)\n"
  "                   (ast-optimize-helper-list (ast-call-operands ast) bounds)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (let ((formals (ast-lambda-formals ast)))\n"
  "           (ast-lambda formals\n"
  "                       (ast-optimize-helper (ast-lambda-body ast)\n"
  "                                            (set-unite bounds formals)))))\n"
  "        ((ast-let?"" ast)\n"
  "         (let ((bound-name (ast-let-bound-name ast)))\n"
  "           (ast-optimize-let bound-name\n"
  "                             (ast-optimize-helper (ast-let-bound-form ast) bounds)\n"
  "                             (ast-optimize-helper (ast-let-body ast)\n"
  "                                                  (set-with bounds bound-name))\n"
  "                             bounds)))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (let ((optimized-first (ast-optimize-helper (ast-sequence-first ast)\n"
  "                                                     bounds))\n"
  "               (optimized-second (ast-optimize-helper (ast-sequence-second ast)\n"
  "                                                      bounds)))\n"
  "           (ast-optimize-sequence optimized-first\n"
  "                                  optimized-second\n"
  "                                  bounds)))))\n"
  "\n"
  ";;; An extension of ast-optimize-helper to a list of ASTs: return the list\n"
  ";;; of rewriten ASTs in order.\n"
  "(define-constant (ast-optimize-helper-list asts bounds)\n"
  "  (map (lambda (ast) (ast-optimize-helper ast bounds))\n"
  "       asts))\n"
  "\n"
  ";;; A helper for ast-optimize-helper in the sequence case.  Assume that both the\n"
  ";;; subforms are already optimized.\n"
  "(define-constant (ast-optimize-sequence optimized-first optimized-second bounds)\n"
  "  (cond ((and (ast-variable?"" optimized-first)\n"
  "              (ast-equal?"" optimized-first optimized-second))\n"
  "         ;; Rewrite [sequence [variable x] [variable x]] into [variable x].\n"
  "         ;; This is correct even if x is not known to be bound, as no effects\n"
  "         ;; are removed: the removed (second) reference is guaranteed not to\n"
  "         ;; have observable effects after the first reference succeeds.\n"
  "         ;; Other optimizations give opportunity for this case to apply.\n"
  "         optimized-first)\n"
  "        ((not (ast-effectful?"" optimized-first bounds))\n"
  "         ;; The first form in the sequence has no effect: rewrite to the second\n"
  "         ;; form only.\n"
  "         optimized-second)\n"
  "        (else\n"
  "         ;; Fallback case: keep the sequence.\n"
  "         (ast-sequence optimized-first\n"
  "                       optimized-second))))\n"
  "\n"
  ";;; A helper for ast-optimize-helper in the set! case.  The body should already\n"
  ";;; be optimized.\n"
  "(define-constant (ast-optimize-set! name body bounds)\n"
  "  ;; There isn't much I can do here without going to extreme lengths.\n"
  "  (cond ((and (ast-variable?"" body)\n"
  "              (eq?"" (ast-variable-name body) name)\n"
  "              (set-has?"" bounds name))\n"
  "         ;; An easy case to optimize is [set! x [variable x]], which we can\n"
  "         ;; rewrite into [literal #<nothing>] as long as x is non-globally bound\n"
  "         ;; (otherwise the reference to x would be effectful, which would make\n"
  "         ;; its removal incorrect).  This occurs, for example, in the\n"
  "         ;; macroexpansion of (letrec ((a a)) a), which is a way of obtaining\n"
  "         ;; #<undefined> as a result.  Notice that [set! x x] is effectful when\n"
  "         ;; x is a global constant, and therefore we do not remove it in that\n"
  "         ;; case; the condition checks whether the variable is bound in the\n"
  "         ;; non-global environement only, on purpose.\n"
  "         (ast-literal (begin)))\n"
  "        (else\n"
  "         ;; Fallback case, in which we optimize nothing.\n"
  "         (ast-set! name body))))\n"
  "\n"
  ";;; A helper for ast-optimize-helper in the let case, which is the most complex.\n"
  ";;; This assumes that both subforms are alpha-converted.\n"
  "(define-constant (ast-optimize-let bound-name bound-form body bounds)\n"
  "  (cond ((ast-sequence?"" bound-form)\n"
  "         ;; Rewrite [let x [sequence E1 E2] E3] into [sequence E1 [let x E2 E3]]\n"
  "         ;; , which may enable further optimizations.  Notice that moving E1 out\n"
  "         ;; of the let form doesn't change the set of bound variables at any\n"
  "         ;; program point, as the bound x is not visible in E1.\n"
  "         ;; So, do the change...\n"
  "         (let ((rewritten\n"
  "                (ast-sequence (ast-sequence-first bound-form)\n"
  "                              (ast-let bound-name\n"
  "                                       (ast-sequence-second bound-form)\n"
  "                                       body))))\n"
  "           ;; ...and then re-optimize the rewritten sequence.  This may trigger\n"
  "           ;; the same rewrite on a bound-form sub-sequence, or other\n"
  "           ;; optimizations; in particular the bound form, now smaller, may have\n"
  "           ;; been reduced to a variable or a literal.\n"
  "           (ast-optimize-helper rewritten bounds)))\n"
  "        ((not (ast-has-free?"" body bound-name))\n"
  "         ;; The bound variable is not used in the body.  Rewrite the let into\n"
  "         ;; a sequence and optimize it further.\n"
  "         (ast-optimize-helper (ast-sequence bound-form body)\n"
  "                              bounds))\n"
  "        ((and (ast-literal?"" bound-form)\n"
  "              (not (ast-has-assigned?"" body bound-name)))\n"
  "         ;; The variable is bound to a literal, without being assigned:\n"
  "         ;; fold the literal into the body and optimize it further.\n"
  "         (let ((folded-body (ast-instantiate body bound-name bound-form)))\n"
  "           (ast-optimize-helper folded-body bounds)))\n"
  "        ((and (ast-variable?"" bound-form)\n"
  "              (not (ast-has-assigned?"" body bound-name))\n"
  "              (not (ast-has-assigned?"" body (ast-variable-name bound-form)))\n"
  "              (or (set-has?"" bounds (ast-variable-name bound-form))\n"
  "                  (constant?"" (ast-variable-name bound-form))))\n"
  "         ;; The variable is bound to another variable, with neither being\n"
  "         ;; assigned in the body.  We can reduce the entire let AST to a body\n"
  "         ;; with the bound variable replaced by the other.  Here we rely on the\n"
  "         ;; body being alpha-converted to be sure not to capture the substituted\n"
  "         ;; variable.\n"
  "         ;; The or clause is important: this rewriting is only valid if we are\n"
  "         ;; sure that referencing the bound-form variable will not have effects;\n"
  "         ;; it being undefined would trigger an error, and we don't want to move\n"
  "         ;; the error point.\n"
  "         (let ((new-body (ast-instantiate body bound-name bound-form)))\n"
  "           (ast-optimize-helper new-body bounds)))\n"
  "        ((and (ast-variable?"" body)\n"
  "              (eq?"" bound-name (ast-variable-name body)))\n"
  "         ;; Rewrite [let x E [variable x]] into E , without any restriction on\n"
  "         ;; the shape of E , on x or on effects.\n"
  "         ;; This rewrite could be subsumed by more general rules which are not\n"
  "         ;; implemented yet but at least this case is easy to optimize, and\n"
  "         ;; an opportunity to improve tailness.  It can occur as a consequence\n"
  "         ;; of other rewrites.\n"
  "         bound-form)\n"
  "        (else\n"
  "         ;; Default case: keep the let AST in our rewriting.\n"
  "         (ast-let bound-name\n"
  "                  bound-form\n"
  "                  (ast-optimize-helper body (set-with bounds bound-name))))))\n"
  "\n"
  ";;; A helper for ast-optimize-helper in the if case.\n"
  "(define-constant (ast-optimize-if condition then else bounds)\n"
  "  (ast-optimize-if-helper (ast-optimize-helper condition bounds)\n"
  "                          (ast-optimize-helper then bounds)\n"
  "                          (ast-optimize-helper else bounds)\n"
  "                          bounds))\n"
  "\n"
  ";;; A helper for ast-optimize-if, requiring every AST sub to be already optimized.\n"
  "(define-constant (ast-optimize-if-helper condition then else bounds)\n"
  "  (cond ((ast-sequence?"" condition)\n"
  "         ;; Rewrite [if [sequence E1 E2] E3 E4] into\n"
  "         ;; [sequence E1 [if E2 E3 E4]], and optimize the result.  This may\n"
  "         ;; lead to further optimizations, particularly if the condition\n"
  "         ;; eventually reduces to a constant.  The set of bound variables\n"
  "         ;; doesn't change at any point.\n"
  "         (let ((sequence\n"
  "                (ast-sequence (ast-sequence-first condition)\n"
  "                              (ast-if (ast-sequence-second condition)\n"
  "                                      then\n"
  "                                      else))))\n"
  "           (ast-optimize-helper sequence bounds)))\n"
  "        ((and (ast-primitive?"" condition)\n"
  "              (eq?"" (ast-primitive-operator condition)\n"
  "                   primitive-boolean-canonicalize))\n"
  "         ;; Rewrite [if [primitive boolean-canonicalize E1] E2 E3] into\n"
  "         ;; [if E1 E2 E3], and optimize the result.  Boolean canonicalization\n"
  "         ;; is a waste of time in this position.\n"
  "         (ast-optimize-if-helper (car (ast-primitive-operands condition))\n"
  "                                 then\n"
  "                                 else\n"
  "                                 bounds))\n"
  "        ((and (ast-primitive?"" condition)\n"
  "              (eq?"" (ast-primitive-operator condition)\n"
  "                   primitive-not))\n"
  "         ;; Rewrite [if [primitive not E1] E2 E3] into [if E1 E3 E2], and\n"
  "         ;; optimize the result.\n"
  "         (ast-optimize-if-helper (car (ast-primitive-operands condition))\n"
  "                                 else\n"
  "                                 then\n"
  "                                 bounds))\n"
  "        ((and (ast-literal?"" condition)\n"
  "              (ast-literal-value condition))\n"
  "         ;; The condition has been simplified to non-#f: rewrite\n"
  "         ;; [if [literal non-#f] E1 E2] into E1.\n"
  "         then)\n"
  "        ((ast-literal?"" condition)\n"
  "         ;; The condition has been simplified to #f, since we didn't\n"
  "         ;; get to the previous clause: rewrite [if [literal #f] E1 E2] into E2.\n"
  "         else)\n"
  "        ((ast-equal?"" then else)\n"
  "         ;; The two branches are equal, so we don't need to have a conditional\n"
  "         ;; at all: turn it into a sequence of the condition and one branch;\n"
  "         ;; this will usually be further optimizable as the condition tends not\n"
  "         ;; to have effects.\n"
  "         ;; Rewrite [if E1 E2 E2] into [sequence E1 E2].\n"
  "         (ast-optimize-helper (ast-sequence condition\n"
  "                                            then)\n"
  "                              bounds))\n"
  "        ((and (ast-equal?"" condition then)\n"
  "              (ast-literal?"" else)\n"
  "              (not (ast-literal-value else))\n"
  "              (not (ast-effectful?"" condition bounds)))\n"
  "         ;; The condition has no effects and is equal to the then branch, with\n"
  "         ;; an else branch which is the literal #f.  This occurs in the\n"
  "         ;; expansion of (and X X) with a non-effectul X.\n"
  "         ;; Rewrite [if E1 E1 [literal #f]] into E1.\n"
  "         condition)\n"
  "        ((and (ast-equal?"" condition else)\n"
  "              (ast-literal?"" then)\n"
  "              (eq?"" (ast-literal-value then) #t) ;; Exactly the canonical #t.\n"
  "              (not (ast-effectful?"" condition bounds)))\n"
  "         ;; The condition has no effects and is equal to the else branch, with\n"
  "         ;; an then branch which is the literal #t -- exactly that canonical\n"
  "         ;; boolean, not any other non-#f value.  This occurs in the\n"
  "         ;; expansion of the non-Lispy (or X X) with a non-effectul X.\n"
  "         ;; Rewrite [if E1 [literal #t] E1] into\n"
  "         ;; [primitive boolean-canonicalize E1].\n"
  "         ;; This is provided for symmetry with the previous case, mostly for\n"
  "         ;; fun.\n"
  "         (ast-optimize-helper (ast-primitive primitive-boolean-canonicalize\n"
  "                                             (list condition))\n"
  "                              bounds))\n"
  "        ((and (ast-primitive?"" else)\n"
  "              (eq?"" (ast-primitive-operator else)\n"
  "                   primitive-boolean-canonicalize)\n"
  "              (ast-equal?"" condition\n"
  "                          (car (ast-primitive-operands else)))\n"
  "              (ast-literal?"" then)\n"
  "              (eq?"" (ast-literal-value then) #t) ;; Exactly the canonical #t.\n"
  "              (not (ast-effectful?"" condition bounds)))\n"
  "         ;; A generalization of the previous case to the expansion of non-Lispy\n"
  "         ;; (or X X ... X).\n"
  "         ;; Rewrite [if E1 [literal #t] [primitive boolean-canonicalize E1]]\n"
  "         ;; into [primitive boolean-canonicalize E1].\n"
  "         (ast-optimize-helper (ast-primitive primitive-boolean-canonicalize\n"
  "                                             (list condition))\n"
  "                              bounds))\n"
  "        ((and (ast-literal?"" then)\n"
  "              (ast-literal?"" else)\n"
  "              (eq?"" (ast-literal-value then) #t) ;; The canonical #t.\n"
  "              (not (ast-literal-value else)))\n"
  "         ;; Rewrite [if E #t #f] into [primitive boolean-canonicalize E]; notice\n"
  "         ;; that there is no requirement on effectfulness or on the shape of the\n"
  "         ;; condition.\n"
  "         ;; This doesn't only occur in dumb code written by human beginners: it\n"
  "         ;; occurs, for example, in the expansion of non-Lispy (or X #f), which\n"
  "         ;; may well come from the expansion of another macro.\n"
  "         (ast-optimize-helper (ast-primitive primitive-boolean-canonicalize\n"
  "                                             (list condition))\n"
  "                              bounds))\n"
  "        ((and (ast-literal?"" then)\n"
  "              (ast-literal?"" else)\n"
  "              (not (ast-literal-value then))\n"
  "              (eq?"" (ast-literal-value else) #t)) ;; The canonical #t.\n"
  "         ;; Rewrite [if E #f #t] into [primitive not E]; again there is no\n"
  "         ;; requirement on effectfulness or on the shape of the condition.\n"
  "         ;; This is symmetrical with respect to the previous case.\n"
  "         (ast-optimize-helper (ast-primitive primitive-not\n"
  "                                             (list condition))\n"
  "                              bounds))\n"
  "        (else\n"
  "         ;; Generic case.  Keep both branches, each optimized separately.\n"
  "         (ast-if condition\n"
  "                 then\n"
  "                 else))))\n"
  "\n"
  ";;; A helper for ast-optimize-helper in the while case.  Only the guard\n"
  ";;; needs to be already optimized.\n"
  "(define-constant (ast-optimize-while optimized-guard body bounds)\n"
  "  (cond ((ast-sequence?"" optimized-guard)\n"
  "         ;; Rewrite [while [sequence E1 E2] E3] into\n"
  "         ;; [sequence E1 [while E2 [sequence E3 E1]]] and optimize further.\n"
  "         ;; The bound variable set doesn't change at any program point.\n"
  "         (let* ((first (ast-sequence-first optimized-guard))\n"
  "                (second (ast-sequence-second optimized-guard))\n"
  "                (sequence (ast-sequence first\n"
  "                                        (ast-while second\n"
  "                                                   (ast-sequence body\n"
  "                                                                 first)))))\n"
  "           (ast-optimize-helper sequence bounds)))\n"
  "        ((and (ast-primitive?"" optimized-guard)\n"
  "              (eq?"" (ast-primitive-operator optimized-guard)\n"
  "                   primitive-boolean-canonicalize))\n"
  "         ;; Rewrite [while [primitive boolean-canonicalize E1] E2] into\n"
  "         ;; [while E1 E2], and optimize the result.  Boolean canonicalization\n"
  "         ;; is a waste of time in this position.\n"
  "         (ast-optimize-while (car (ast-primitive-operands optimized-guard))\n"
  "                             body\n"
  "                             bounds))\n"
  "        ((and (ast-literal?"" optimized-guard)\n"
  "              (not (ast-literal-value optimized-guard)))\n"
  "         ;; Replace [while [literal #f] E] with [literal #<nothing>].  This is\n"
  "         ;; correct with any E, even if it has effects.  Notice that we can't\n"
  "         ;; simplify while with a constantly non-#f guard.\n"
  "         (ast-literal (begin)))\n"
  "        (else\n"
  "         ;; Keep the while form.\n"
  "         (ast-while optimized-guard\n"
  "                    (ast-optimize-helper body bounds)))))\n"
  "\n"
  ";;; Return a rewritten version of a primitive use with the given primitive\n"
  ";;; operator and the given list of AST operands, already rewritten.\n"
  "(define-constant (ast-optimize-primitive primitive operands)\n"
  "  ;; Here I can assume the primitive in-arity to be respected: there would\n"
  "  ;; have been an error at AST creation time otherwise.\n"
  "  (cond ;; Successor and predecessor; multiplication, division and remainder by\n"
  "        ;; two.\n"
  "        ((and (eq?"" primitive primitive-primordial-+) (ast-one?"" (car operands)))\n"
  "         ;; [primitive primordial-+ 1 E] ==> [primitive 1+ E]\n"
  "         (ast-optimize-primitive primitive-1+ (list (cadr operands))))\n"
  "        ((and (eq?"" primitive primitive-primordial-+) (ast-one?"" (cadr operands)))\n"
  "         ;; [primitive primordial-+ E 1] ==> [primitive 1+ E]\n"
  "         (ast-optimize-primitive primitive-1+ (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-primordial-*) (ast-two?"" (car operands)))\n"
  "         ;; [primitive primordial-* 2 E] ==> [primitive 2* E]\n"
  "         (ast-optimize-primitive primitive-2* (list (cadr operands))))\n"
  "        ((and (eq?"" primitive primitive-primordial-*) (ast-two?"" (cadr operands)))\n"
  "         ;; [primitive primordial-* E 2] ==> [primitive 2* E]\n"
  "         (ast-optimize-primitive primitive-2* (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-primordial--) (ast-one?"" (cadr operands)))\n"
  "         ;; [primitive primordial-- E 1] ==> [primitive 1- E]\n"
  "         (ast-optimize-primitive primitive-1- (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-primordial-+)\n"
  "              (ast-minus-one?"" (car operands)))\n"
  "         ;; [primitive primordial-+ -1 E] ==> [primitive 1- E]\n"
  "         (ast-optimize-primitive primitive-1- (list (cadr operands))))\n"
  "        ((and (eq?"" primitive primitive-primordial-+)\n"
  "              (ast-minus-one?"" (cadr operands)))\n"
  "         ;; [primitive primordial-+ E -1] ==> [primitive 1- E]\n"
  "         (ast-optimize-primitive primitive-1- (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-primordial--)\n"
  "              (ast-minus-one?"" (cadr operands)))\n"
  "         ;; [primitive primordial-- E -1] ==> [primitive 1+ E]\n"
  "         (ast-optimize-primitive primitive-1+ (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-primordial-/) (ast-two?"" (cadr operands)))\n"
  "         ;; [primitive primordial-/ E 2] ==> [primitive 2/ E]\n"
  "         (ast-optimize-primitive primitive-2/ (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-quotient)\n"
  "              (ast-two?"" (cadr operands)))\n"
  "         ;; [primitive quotient E 2] ==> [primitive 2quotient E]\n"
  "         (ast-optimize-primitive primitive-2quotient (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-remainder) (ast-two?"" (cadr operands)))\n"
  "         ;; [primitive remainder E 2] ==> [primitive 2remainder E]\n"
  "         (ast-optimize-primitive primitive-2remainder (list (car operands))))\n"
  "        ;; Zero tests.\n"
  "        ((and (eq?"" primitive primitive-=) (ast-zero?"" (car operands)))\n"
  "         ;; [primitive = 0 E] ==> [primitive zero?"" E]\n"
  "         (ast-optimize-primitive primitive-zero?"" (list (cadr operands))))\n"
  "        ((and (eq?"" primitive primitive-=) (ast-zero?"" (cadr operands)))\n"
  "         ;; [primitive = E 0] ==> [primitive zero?"" E]\n"
  "         (ast-optimize-primitive primitive-zero?"" (list (car operands))))\n"
  "        ;; Sign tests.\n"
  "        ((and (eq?"" primitive primitive-<) (ast-zero?"" (cadr operands)))\n"
  "         ;; [primitive < E 0] ==> [primitive negative?"" E]\n"
  "         (ast-optimize-primitive primitive-negative?"" (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-<=) (ast-zero?"" (cadr operands)))\n"
  "         ;; [primitive <= E 0] ==> [primitive non-positive?"" E]\n"
  "         (ast-optimize-primitive primitive-non-positive?"" (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive->) (ast-zero?"" (cadr operands)))\n"
  "         ;; [primitive > E 0] ==> [primitive positive?"" E]\n"
  "         (ast-optimize-primitive primitive-positive?"" (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive->=) (ast-zero?"" (cadr operands)))\n"
  "         ;; [primitive >= E 0] ==> [primitive non-negative?"" E]\n"
  "         (ast-optimize-primitive primitive-non-negative?"" (list (car operands))))\n"
  "        ((and (eq?"" primitive primitive-<) (ast-zero?"" (car operands)))\n"
  "         ;; [primitive < 0 E] ==> [primitive positive?"" E]\n"
  "         (ast-optimize-primitive primitive-positive?"" (list (cadr operands))))\n"
  "        ((and (eq?"" primitive primitive-<=) (ast-zero?"" (car operands)))\n"
  "         ;; [primitive <= 0 E] ==> [primitive non-negative?"" E]\n"
  "         (ast-optimize-primitive primitive-non-negative?"" (list (cadr operands))))\n"
  "        ((and (eq?"" primitive primitive->) (ast-zero?"" (car operands)))\n"
  "         ;; [primitive > 0 E] ==> [primitive negative?"" E]\n"
  "         (ast-optimize-primitive primitive-negative?"" (list (cadr operands))))\n"
  "        ((and (eq?"" primitive primitive->=) (ast-zero?"" (car operands)))\n"
  "         ;; [primitive >= 0 E] ==> [primitive non-positive?"" E]\n"
  "         (ast-optimize-primitive primitive-non-positive?"" (list (cadr operands))))\n"
  "        ;; Arithmetic with neutral operands.\n"
  "        ;; Notice that we cannot, in general, rewrite primitives with absorbing\n"
  "        ;; operands without removing effects; however neutral operands are fine.\n"
  "        ((and (eq?"" primitive primitive-primordial-+) (ast-zero?"" (car operands)))\n"
  "         ;; [primitive + 0 E] ==> E\n"
  "         (cadr operands))\n"
  "        ((and (eq?"" primitive primitive-primordial-+) (ast-zero?"" (cadr operands)))\n"
  "         ;; [primitive + E 0] ==> E\n"
  "         (car operands))\n"
  "        ((and (eq?"" primitive primitive-primordial--) (ast-zero?"" (cadr operands)))\n"
  "         ;; [primitive - E 0] ==> E\n"
  "         (car operands))\n"
  "        ((and (eq?"" primitive primitive-primordial-*) (ast-one?"" (car operands)))\n"
  "         ;; [primitive * 1 E] ==> E\n"
  "         (cadr operands))\n"
  "        ((and (eq?"" primitive primitive-primordial-*) (ast-one?"" (cadr operands)))\n"
  "         ;; [primitive * E 1] ==> E\n"
  "         (car operands))\n"
  "        ((and (eq?"" primitive primitive-primordial-/) (ast-one?"" (cadr operands)))\n"
  "         ;; [primitive / E 1] ==> E\n"
  "         (car operands))\n"
  "        ;; Division and remainder by non-zero literals.\n"
  "        ((and (eq?"" primitive primitive-primordial-/)\n"
  "              (ast-non-zero?"" (cadr operands)))\n"
  "         ;; [primitive / E NZ] ==> [primitive /-unsafe E NZ]\n"
  "         (ast-optimize-primitive primitive-primordial-/-unsafe operands))\n"
  "        ((and (eq?"" primitive primitive-quotient)\n"
  "              (ast-non-zero?"" (cadr operands)))\n"
  "         ;; [primitive quotient E NZ] ==> [primitive quotient-unsafe E NZ]\n"
  "         (ast-optimize-primitive primitive-quotient-unsafe operands))\n"
  "        ((and (eq?"" primitive primitive-remainder)\n"
  "              (ast-non-zero?"" (cadr operands)))\n"
  "         ;; [primitive remainder E NZ] ==> [primitive remainder-unsafe E NZ]\n"
  "         (ast-optimize-primitive primitive-remainder-unsafe operands))\n"
  "        ;; Other arithmetic simplification with particular literal operands.\n"
  "        ((and (eq?"" primitive primitive-primordial--) (ast-zero?"" (car operands)))\n"
  "         ;; [primitive - 0 E] ==> [primitive negate E]\n"
  "         (ast-optimize-primitive primitive-negate (list (cadr operands))))\n"
  "        ;; Nested arithmetic negation.\n"
  "        ((and (eq?"" primitive primitive-negate)\n"
  "              (ast-primitive?"" (car operands))\n"
  "              (eq?"" (ast-primitive-operator (car operands)) primitive-negate))\n"
  "         ;; [primitive negate [primitive negate E]] ==> E\n"
  "         (car (ast-primitive-operands (car operands))))\n"
  "        ;; Logical negation of another primitive.\n"
  "        ((and (eq?"" primitive primitive-not)\n"
  "              (ast-primitive?"" (car operands)))\n"
  "         ;; [primitive not [primitive P . Es]].\n"
  "         ;; Some primitives can be rewritten into a faster form when logically\n"
  "         ;; negated.  Use the helper procedure for this.\n"
  "         (let ((inner-primitive (ast-primitive-operator (car operands)))\n"
  "               (inner-operands (ast-primitive-operands (car operands))))\n"
  "           (ast-optimize-not-primitive inner-primitive inner-operands)))\n"
  "        ((for-all?"" ast-literal?"" operands)\n"
  "         ;; The actuals are all literals.  Try to evaluate the primitive use\n"
  "         ;; at rewrite time, replacing it with a literal result.\n"
  "         (ast-optimize-primitive-known-actuals primitive\n"
  "                                               (map ast-literal-value\n"
  "                                                    operands)))\n"
  "        (else\n"
  "         ;; Fallback case: we have nothing to rewrite.\n"
  "         (ast-primitive primitive operands))))\n"
  "\n"
  ";;; Return non-#f iff the given AST is a literal with the given value.\n"
  "(define-constant (ast-literal-value?"" ast value)\n"
  "  (and (ast-literal?"" ast)\n"
  "       (eq?"" (ast-literal-value ast) value)))\n"
  "\n"
  ";;; Return non-#f iff the given AST is repsectively the literal 0, 1, -1, 2.\n"
  "(define-constant (ast-zero?"" ast)\n"
  "  (ast-literal-value?"" ast 0))\n"
  "(define-constant (ast-one?"" ast)\n"
  "  (ast-literal-value?"" ast 1))\n"
  "(define-constant (ast-minus-one?"" ast)\n"
  "  (ast-literal-value?"" ast -1))\n"
  "(define-constant (ast-two?"" ast)\n"
  "  (ast-literal-value?"" ast 2))\n"
  "\n"
  ";;; Return non-#f iff the given AST is a fixnum non-zero literal.\n"
  "(define-constant (ast-non-zero?"" ast)\n"
  "  (and (ast-literal?"" ast)\n"
  "       (non-zero?"" (ast-literal-value ast))))\n"
  "\n"
  ";;; A helper for ast-optimize-primitive.  Return the rewritten version of\n"
  ";;; [primitive not [primitive PRIMITIVE . OPERANDS]].  The operands are already\n"
  ";;; rewritten.\n"
  "(define-constant (ast-optimize-not-primitive primitive operands)\n"
  "  ;; Like in ast-optimize-primitive , I can assume that the in-arity is\n"
  "  ;; respected.\n"
  "  (cond ((eq?"" primitive primitive-not)\n"
  "         ;; [primitive not [primitive not E]] ==> [boolean-canonicalize E].\n"
  "         ;; A use of boolean-canonicalize as an condition will be rewritten\n"
  "         ;; away by the if and while helpers.\n"
  "         (ast-optimize-primitive primitive-boolean-canonicalize operands))\n"
  "        ((eq?"" primitive primitive-boolean-canonicalize)\n"
  "         ;; [primitive not [primitive boolean-canonicalize E]] ==>\n"
  "         ;; [primitive not E].\n"
  "         (ast-optimize-primitive primitive-not operands))\n"
  "        ;; The following cases are obvious.\n"
  "        ((eq?"" primitive primitive-null?"")\n"
  "         ;; [primitive not [primitive null?"" . Es]] ==> [primitive non-null?"" . Es]\n"
  "         (ast-optimize-primitive primitive-non-null?"" operands))\n"
  "        ((eq?"" primitive primitive-non-null?"")\n"
  "         ;; [primitive not [primitive non-null?"" . Es]] ==> [primitive null?"" . Es]\n"
  "         (ast-optimize-primitive primitive-null?"" operands))\n"
  "        ((eq?"" primitive primitive-eq?"")\n"
  "         ;; [primitive not [primitive eq?"" . Es]] ==> [primitive not-eq?"" . Es]\n"
  "         (ast-optimize-primitive primitive-not-eq?"" operands))\n"
  "        ((eq?"" primitive primitive-not-eq?"")\n"
  "         ;; [primitive not [primitive not-eq?"" . Es]] ==> [primitive eq?"" . Es]\n"
  "         (ast-optimize-primitive primitive-eq?"" operands))\n"
  "        ((eq?"" primitive primitive-zero?"")\n"
  "         ;; [primitive not [primitive zero?"" . Es]] ==> [primitive non-zero?"" . Es]\n"
  "         (ast-optimize-primitive primitive-non-zero?"" operands))\n"
  "        ((eq?"" primitive primitive-non-zero?"")\n"
  "         ;; [primitive not [primitive non-zero?"" . Es]] ==> [primitive zero?"" . Es]\n"
  "         (ast-optimize-primitive primitive-zero?"" operands))\n"
  "        ((eq?"" primitive primitive-positive?"")\n"
  "         ;; [primitive not [primitive positive?"" . Es]] ==> [primitive non-positive?"" . Es]\n"
  "         (ast-optimize-primitive primitive-non-positive?"" operands))\n"
  "        ((eq?"" primitive primitive-non-positive?"")\n"
  "         ;; [primitive not [primitive non-positive?"" . Es]] ==> [primitive positive?"" . Es]\n"
  "         (ast-optimize-primitive primitive-positive?"" operands))\n"
  "        ((eq?"" primitive primitive-negative?"")\n"
  "         ;; [primitive not [primitive negative?"" . Es]] ==> [primitive non-negative?"" . Es]\n"
  "         (ast-optimize-primitive primitive-non-negative?"" operands))\n"
  "        ((eq?"" primitive primitive-non-negative?"")\n"
  "         ;; [primitive not [primitive non-negative?"" . Es]] ==> [primitive negative?"" . Es]\n"
  "         (ast-optimize-primitive primitive-negative?"" operands))\n"
  "        ((eq?"" primitive primitive-=)\n"
  "         ;; [primitive not [primitive = . Es]] ==> [primitive <> . Es]\n"
  "         (ast-optimize-primitive primitive-<> operands))\n"
  "        ((eq?"" primitive primitive-<>)\n"
  "         ;; [primitive not [primitive <> . Es]] ==> [primitive = . Es]\n"
  "         (ast-optimize-primitive primitive-= operands))\n"
  "        ((eq?"" primitive primitive-<)\n"
  "         ;; [primitive not [primitive < . Es]] ==> [primitive >= . Es]\n"
  "         (ast-optimize-primitive primitive->= operands))\n"
  "        ((eq?"" primitive primitive-<=)\n"
  "         ;; [primitive not [primitive <= . Es]] ==> [primitive > . Es]\n"
  "         (ast-optimize-primitive primitive-> operands))\n"
  "        ((eq?"" primitive primitive->)\n"
  "         ;; [primitive not [primitive > . Es]] ==> [primitive <= . Es]\n"
  "         (ast-optimize-primitive primitive-<= operands))\n"
  "        ((eq?"" primitive primitive->=)\n"
  "         ;; [primitive not [primitive >= . Es]] ==> [primitive < . Es]\n"
  "         (ast-optimize-primitive primitive-< operands))\n"
  "        (else\n"
  "         ;; Fallback case: don't rewrite anything.\n"
  "         (ast-primitive primitive-not\n"
  "                        (list (ast-primitive primitive operands))))))\n"
  "\n"
  ";;; Another helper for ast-optimize-primitive.  Return an AST containing a\n"
  ";;; rewritten primitive use of the given primitive with the given values (all\n"
  ";;; known at rewrite time) as actuals; in some cases we can evaluate the\n"
  ";;; primitive use at rewrite time, and replace it with the result as a literal.\n"
  "(define-constant (ast-optimize-primitive-known-actuals primitive values)\n"
  "  ;; Again I can assume that the in-arity is respected, but not necessarily the\n"
  "  ;; actual types.\n"
  "  (if (ast-statically-rewritable-primitive-use?"" primitive values)\n"
  "      (ast-literal (apply-primitive primitive values))\n"
  "      (ast-primitive primitive (map ast-literal values))))\n"
  "\n"
  ";;; Given a primitive and a list of actual values return non-#f iff the use is\n"
  ";;; known to be statically rewritable.\n"
  "(define-constant (ast-statically-rewritable-primitive-use?"" primitive values)\n"
  "  (let outer-loop ((signatures ast-statically-rewritable-primitive-signatures))\n"
  "    (if (null?"" signatures)\n"
  "        #f\n"
  "        (let* ((signature (car signatures))\n"
  "               (a-primitive (car signature))\n"
  "               (conditions (cdr signature)))\n"
  "          ;; In the inner loop it's convenient to iterate on a list of\n"
  "          ;; predicates; so instead of a primitive object I will use as the\n"
  "          ;; first element a predicate checking whether its argument is the\n"
  "          ;; required primitive.  The list of values to match with the list of\n"
  "          ;; predicates contains the primitives as the first element, followed\n"
  "          ;; by the actual values.\n"
  "          (let inner-loop ((conditions (cons (lambda (p) (eq?"" a-primitive p))\n"
  "                                             conditions))\n"
  "                           (values (cons primitive values)))\n"
  "            (cond ((and (null?"" conditions) (null?"" values))\n"
  "                   ;; Every condition was satisfied and there are no excess\n"
  "                   ;; actuals: the signature matches.\n"
  "                   #t)\n"
  "                  ((null?"" conditions)\n"
  "                   ;; No more conditions, but still remaining actuals.\n"
  "                   (display `(WARNING: invalid signature: too many actuals for ,primitive)) (newline)\n"
  "                   (outer-loop (cdr signatures)))\n"
  "                  ((null?"" values)\n"
  "                   ;; No more actuals, but still remaining conditions.\n"
  "                   (display `(WARNING: invalid signature: not enough actuals for ,primitive)) (newline)\n"
  "                   (outer-loop (cdr signatures)))\n"
  "                  (((car conditions) (car values))\n"
  "                   ;; The first condition on the first actual is satisfied.\n"
  "                   ;; Check the others.\n"
  "                   (inner-loop (cdr conditions) (cdr values)))\n"
  "                  (else\n"
  "                   ;; The first condition on the first actual is not satisfied.\n"
  "                   ;; Leave this signature and try with the next.\n"
  "                   (outer-loop (cdr signatures)))))))))\n"
  "\n"
  "\n"
  ";;; Return non-#f iff the argument is a fixnum and different from 0.  Never\n"
  ";;; fail.\n"
  "(define-constant (non-zero-fixnum?"" x)\n"
  "  (and (fixnum?"" x)\n"
  "       (non-zero?"" x)))\n"
  "\n"
  ";;; An unordered list of lists.  Each inner list contains a primitive, and then\n"
  ";;; one procedure per primitive argument; the procedure is a predicate never\n"
  ";;; failing and returning #t if the argument is suitable for the primitive, and\n"
  ";;; safe to evaluate at rewrite time.\n"
  ";;; Primitives not occurring here ar not candidates for rewrite-time evaluation.\n"
  ";;;\n"
  ";;; The outer list is walked sequentially, looking for the first match; it is\n"
  ";;; possible for a primitive to appear in multiple lists, and that could be\n"
  ";;; useful for primitives with multiple \"safe signatures\".\n"
  "(define-constant ast-statically-rewritable-primitive-signatures\n"
  "  (list ;; Type checking.\n"
  "        (list primitive-null?"" anything?"")\n"
  "        (list primitive-non-null?"" anything?"")\n"
  "        (list primitive-fixnum?"" anything?"")\n"
  "        (list primitive-character?"" anything?"")\n"
  "        (list primitive-symbol?"" anything?"")\n"
  "        (list primitive-non-symbol?"" anything?"")\n"
  "        (list primitive-cons?"" anything?"")\n"
  "        (list primitive-non-cons?"" anything?"")\n"
  "        (list primitive-box?"" anything?"")\n"
  "        (list primitive-primitive?"" anything?"")\n"
  "        (list primitive-closure?"" anything?"")\n"
  "        (list primitive-vector?"" anything?"")\n"
  "        (list primitive-ast?"" anything?"")\n"
  "        (list primitive-macro?"" anything?"")\n"
  "        (list primitive-boolean?"" anything?"")\n"
  "        (list primitive-eof?"" anything?"")\n"
  "        (list primitive-nothing?"" anything?"")\n"
  "        (list primitive-undefined?"" anything?"")\n"
  "\n"
  "        ;; Case checking.  It's probably not worth the trouble to do this for\n"
  "        ;; ASTs.\n"
  "        (list primitive-zero?"" fixnum?"")\n"
  "        (list primitive-non-zero?"" fixnum?"")\n"
  "        (list primitive-positive?"" fixnum?"")\n"
  "        (list primitive-non-positive?"" fixnum?"")\n"
  "        (list primitive-negative?"" fixnum?"")\n"
  "        (list primitive-non-negative?"" fixnum?"")\n"
  "\n"
  "        ;; Generic comparisons.\n"
  "        (list primitive-eq?"" anything?"" anything?"")\n"
  "        (list primitive-not-eq?"" anything?"" anything?"")\n"
  "\n"
  "        ;; Fixnum arithmetic.\n"
  "        (list primitive-1+ fixnum?"")\n"
  "        (list primitive-1- fixnum?"")\n"
  "        (list primitive-negate fixnum?"")\n"
  "        (list primitive-primordial-+ fixnum?"" fixnum?"")\n"
  "        (list primitive-primordial-- fixnum?"" fixnum?"")\n"
  "        (list primitive-primordial-* fixnum?"" fixnum?"")\n"
  "        (list primitive-primordial-/ fixnum?"" non-zero-fixnum?"")\n"
  "        (list primitive-remainder fixnum?"" non-zero-fixnum?"")\n"
  "\n"
  "        ;; Fixnum comparisons.\n"
  "        (list primitive-= fixnum?"" fixnum?"")\n"
  "        (list primitive-<> fixnum?"" fixnum?"")\n"
  "        (list primitive-< fixnum?"" fixnum?"")\n"
  "        (list primitive-<= fixnum?"" fixnum?"")\n"
  "        (list primitive-> fixnum?"" fixnum?"")\n"
  "        (list primitive->= fixnum?"" fixnum?"")\n"
  "\n"
  "        ;; Boolean operations.\n"
  "        (list primitive-not anything?"")\n"
  "        (list primitive-boolean-canonicalize anything?"")\n"
  "\n"
  "        ;; Conses.\n"
  "        ;; It is *not* safe to evaluate cons at rewrite time, as it needs to\n"
  "        ;; allocate a different fresh object at every use.  More subtly, it's\n"
  "        ;; also unsafe to evaluate selectors at rewrite time, as the data\n"
  "        ;; structures involved might be destructively updated at run time\n"
  "        ;; between initialization and selection.\n"
  "\n"
  "        ;; Boxes.\n"
  "        ;; The comment above about cons selectors applies to boxes as well.\n"
  "        ))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; AST optimization driver.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Return an optimized version of the given AST where the given set-as-list of\n"
  ";;; variables is bound.\n"
  "(define-constant (ast-optimize-procedure ast-0 bounds)\n"
  "  (let* (;; Fold global constants into the AST.  This will introduce, in\n"
  "         ;; particular, closure literals as operators.\n"
  "         ;;(_ (display `(ast-0: ,ast-0)) (newline))\n"
  "         (ast-1 (ast-global-fold ast-0 bounds))\n"
  "         ;;(_ (display `(ast-1: ,ast-1)) (newline))\n"
  "         ;; Alpha-convert every variable bound by the AST: we are about to\n"
  "         ;; introduce new let bindings, and we need to prevent capture.\n"
  "         (ast-2 (ast-alpha-convert ast-1))\n"
  "         ;;(_ (display `(ast-2: ,ast-2)) (newline))\n"
  "         ;; Translate calls to closures literals into let forms,\n"
  "         ;; alpha-converting the inlined procedures.  This should make almost\n"
  "         ;; all primitives explicit in the AST eliminating closure wrappers for\n"
  "         ;; primitives, at the cost of introducing many redundant lets.\n"
  "         ;; ast-3 will still be alpha-converted, with all bound variables\n"
  "         ;; different from one another.\n"
  "         (ast-3 (ast-simplify-calls ast-2))\n"
  "         ;;(_ (display `(ast-3: ,ast-3)) (newline))\n"
  "         ;; Remove redundancy.\n"
  "         (ast-4 (ast-optimize-helper ast-3 bounds))\n"
  "         ;;(_ (display `(ast-4: ,ast-4)) (newline))\n"
  "         ;;(_  (newline))\n"
  "         )\n"
  "    ast-4))\n"
  "\n"
  ";;; A convenience macro allowing to omit the bounds argument, taken as () when\n"
  ";;; missing.\n"
  "(define-macro (ast-optimize ast . optional-bounds)\n"
  "  (unless (null-or-singleton?"" optional-bounds)\n"
  "    (error `(ast-optimize: optional arguments ,optional-bounds\n"
  "                           not null nor a singleton)))\n"
  "  `(ast-optimize-procedure ,ast ,(car-or-nil optional-bounds)))\n"
  "\n"
  ";;; Given a closure consistently alpha-convert it and return a list of\n"
  ";;; three elements:\n"
  ";;; - the new closure environment;\n"
  ";;; - the new formals;\n"
  ";;; - the new body.\n"
  "(define-constant (closure-alpha-convert closure)\n"
  "  ;; Bind the fields from the unoptimized closure.\n"
  "  (let ((env (interpreted-closure-environment closure))\n"
  "        (formals (interpreted-closure-formals closure))\n"
  "        (body (interpreted-closure-body closure)))\n"
  "    ;; Compute new fields.\n"
  "    (let* ((unary-gensym (lambda (useless) (gensym)))\n"
  "           (nonlocals (map car env))\n"
  "           (fresh-formals (map unary-gensym formals))\n"
  "           (fresh-nonlocals (map unary-gensym env))\n"
  "           (alpha-converted-env (zip fresh-nonlocals (map cdr env)))\n"
  "           (alpha-conversion-alist\n"
  "            (append (zip formals fresh-formals)\n"
  "                    (zip nonlocals fresh-nonlocals)))\n"
  "           (alpha-converted-body\n"
  "            (ast-alpha-convert-with body alpha-conversion-alist)))\n"
  "      ;; Return the results.\n"
  "      (list alpha-converted-env\n"
  "            fresh-formals\n"
  "            alpha-converted-body))))\n"
  "\n"
  ";;; Destructively modify the given closure, consistently alpha-converting its\n"
  ";;; nonlocals, formals and body.\n"
  "(define-constant (closure-alpha-convert! closure)\n"
  "  (let* ((fields (closure-alpha-convert closure))\n"
  "         (alpha-converted-env (car fields))\n"
  "         (alpha-converted-formals (cadr fields))\n"
  "         (alpha-converted-body (caddr fields)))\n"
  "    ;; Set all the fields, at the same time.  Doing this in more than one\n"
  "    ;; operation would be dangerous as the closure we are updating might be\n"
  "    ;; used in the update process itself, which would make visible fields in a\n"
  "    ;; temporarily inconsistent state.\n"
  "    (interpreted-closure-set! closure\n"
  "                              alpha-converted-env\n"
  "                              alpha-converted-formals\n"
  "                              alpha-converted-body\n"
  "                  )))\n"
  "\n"
  ";;; Destructively modify the given closure, replacing its fields with a\n"
  ";;; semantically equivalent optimized version.\n"
  "(define-constant (interpreted-closure-optimize! closure)\n"
  "  (when (compiled-closure?"" closure)\n"
  "    (error `(cannot optimize the already compiled closure ,closure)))\n"
  "  ;; First alpha-convert the closure; optimization might rely on this.\n"
  "  (let* ((fields (closure-alpha-convert closure))\n"
  "         (alpha-converted-env (car fields))\n"
  "         (alpha-converted-formals (cadr fields))\n"
  "         (alpha-converted-body (caddr fields)))\n"
  "    ;; Set all the fields, at the same time, like in closure-alpha-convert! ;\n"
  "    ;; but in this case use an optimized version of the body.\n"
  "    (let* ((alpha-converted-bounds (set-unite alpha-converted-formals\n"
  "                                              (map car alpha-converted-env)))\n"
  "           (optimized-body (ast-optimize alpha-converted-body\n"
  "                                         alpha-converted-bounds)))\n"
  "      (interpreted-closure-set! closure\n"
  "                                alpha-converted-env\n"
  "                                alpha-converted-formals\n"
  "                                optimized-body\n"
  "                                ))))\n"
  "\n"
  ";;; Destructively modify the given closure, replacing its fields with a\n"
  ";;; semantically equivalent optimized version.  Return the argument.  This is a\n"
  ";;; trivial convenience wrapper around interpreted-closure-optimize! , meant for\n"
  ";;; interactive use.\n"
  "(define-constant (interpreted-closure-optimize closure)\n"
  "  (interpreted-closure-optimize! closure)\n"
  "  closure)\n"
  "\n"
  ";;; Another convenience wrapper for interactive use, also accepting (and\n"
  ";;; currently doing nothing on) compiled closures.\n"
  "(define-constant (closure-optimize closure)\n"
  "  (unless (closure?"" closure)\n"
  "    (error `(closure-optimized called on non-closure ,closure)))\n"
  "  (when (interpreted-closure?"" closure)\n"
  "    (interpreted-closure-optimize! closure))\n"
  "  closure)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Retroactive optimization.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Optimize composed cons accessors.  Those are important for performance, and\n"
  ";;; the rewriting itself, which should be fast.\n"
  "(define-constant (optimize-cons-accessors-retroactively!)\n"
  "  ;; I want to flatten composed cons accessors, making them all leaf procedures\n"
  "  ;; each only using primitives and one variable.\n"
  "  ;; First inline cons accessors of size 2, which will flatten them; then do the\n"
  "  ;; same with cons accessors of size 3 (defined using accessors of size 2),\n"
  "  ;; which will flatten them as well; then cons accessors of size 4.\n"
  "  (let ((2-accessors (list caar cadr cdar cddr\n"
  "                           set-caar! set-cadr! set-cdar! set-cddr!))\n"
  "        (3-accessors (list caaar caadr cadar caddr\n"
  "                           cdaar cdadr cddar cdddr\n"
  "                           set-caaar! set-caadr! set-cadar! set-caddr!\n"
  "                           set-cdaar! set-cdadr! set-cddar! set-cdddr!))\n"
  "        (4-accessors (list caaaar caaadr caadar caaddr\n"
  "                           cadaar cadadr caddar cadddr\n"
  "                           cdaaar cdaadr cdadar cdaddr\n"
  "                           cddaar cddadr cdddar cddddr\n"
  "                           set-caaaar! set-caaadr! set-caadar! set-caaddr!\n"
  "                           set-cadaar! set-cadadr! set-caddar! set-cadddr!\n"
  "                           set-cdaaar! set-cdaadr! set-cdadar! set-cdaddr!\n"
  "                           set-cddaar! set-cddadr! set-cdddar! set-cddddr!)))\n"
  "    (dolist (accessor 2-accessors)\n"
  "      (optimize-when-interpreted-closure! accessor))\n"
  "    (dolist (accessor 3-accessors)\n"
  "      (optimize-when-interpreted-closure! accessor))\n"
  "    (dolist (accessor 4-accessors)\n"
  "      (optimize-when-interpreted-closure! accessor))))\n"
  "\n"
  ";;; Optimize every globally defined closure, constant or not, therefore\n"
  ";;; retroactively optimizing the code defined up to this point.\n"
  ";;; This is defined in a procedure to make it easy to disable, as the\n"
  ";;; optimization process itself may be relatively inefficient.\n"
  "(define-constant (optimize-global-closures-retroactively!)\n"
  "  ;; AST rewriting will inline leaf calls, and therefore rewriting may turn a\n"
  "  ;; non-leaf procedure into a leaf procedure, enabling more rewriting.  Doing\n"
  "  ;; this systematically until no more leaf inlining is possible would require\n"
  "  ;; a call graph, or some very inefficient alternative.\n"
  "  ;; I accept this approximation: once the cons composed selectors are\n"
  "  ;; flattened optimize *every* closure, just once, in an unspecified order.\n"
  "  ;; Optimizations other than leaf inlining should not be affected by the\n"
  "  ;; order.\n"
  "  (dolist (symbol (interned-symbols))\n"
  "    (when (and (defined?"" symbol)\n"
  "               (closure?"" (symbol-global symbol)))\n"
  "      (display `(optimizing ,symbol)) (newline)\n"
  "      (optimize-when-interpreted-closure! (symbol-global symbol)))))\n"
  "\n"
  ";;; Flatten composed cons accessors and optimize everything else once.\n"
  "(define-constant (optimize-retroactively!)\n"
  "  (optimize-cons-accessors-retroactively!)\n"
  "  (optimize-global-closures-retroactively!))\n"
  "\n"
  ";; Perform the retroactive rewriting.  This is the call to disable if a low\n"
  ";; startup latency matters more than execution speed.\n"
  ";;(optimize-retroactively!)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Variadic eval and macroexpand.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; FIXME: use null-or-singleton?"" and car-or-nil .  Possibly define a\n"
  ";;; helper macro just for this case, which should be common.\n"
  "\n"
  "(define-macro (eval form . optional-environment)\n"
  "  (if (null?"" optional-environment)\n"
  "      `(primordial-eval ,form ())\n"
  "      `(primordial-eval ,form ,@optional-environment)))\n"
  "(define-macro (eval-interpreter form . optional-environment)\n"
  "  (if (null?"" optional-environment)\n"
  "      `(primordial-eval-interpreter ,form ())\n"
  "      `(primordial-eval-interpreter ,form ,@optional-environment)))\n"
  "(define-macro (eval-vm form . optional-environment)\n"
  "  (if (null?"" optional-environment)\n"
  "      `(primordial-eval-vm ,form ())\n"
  "      `(primordial-eval-vm ,form ,@optional-environment)))\n"
  "\n"
  "(define-macro (macroexpand form . optional-environment)\n"
  "  (if (null?"" optional-environment)\n"
  "      `(primordial-macroexpand ,form ())\n"
  "      `(primordial-macroexpand ,form ,@optional-environment)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; Compiler.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiler utility code.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Given a set-as-list of fixnums, return the minimum non-negative fixnum not\n"
  ";;; within the set.\n"
  "(define-constant (compiler-smallest-not-in set)\n"
  "  (let loop ((candidate 0))\n"
  "    (if (set-has?"" set candidate)\n"
  "        (loop (1+ candidate))\n"
  "        candidate)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiler state structure.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; The compiler state, conceptually a mutable record, is crudely implemented as\n"
  ";;; a mutable list with each field in a fixed position.\n"
  ";;; Notice that it's the list *elements* which are modifiable, and not the list\n"
  ";;; *spine*.  This makes accessors a little nicer to write.\n"
  "(define-constant (compiler-make-state)\n"
  "  (list ()                          ;; instructions\n"
  "        0                           ;; next-label\n"
  "        ()                          ;; bindings\n"
  "        ()                          ;; constant names being compiled (set)\n"
  "        ;; Here begins the second part of the state (its cddddr).\n"
  "        ()                          ;; closures being compiled (set)\n"
  "        (compiler-flags-default)))  ;; flags\n"
  "\n"
  "(define-constant (compiler-reversed-instructions state)\n"
  "  (car state))\n"
  "(define-constant (compiler-set-reversed-instructions! state new-field)\n"
  "  (set-car! state new-field))\n"
  "\n"
  "(define-constant (compiler-next-label state)\n"
  "  (cadr state))\n"
  "(define-constant (compiler-set-next-label! state new-field)\n"
  "  (set-cadr! state new-field))\n"
  "\n"
  "(define-constant (compiler-bindings state)\n"
  "  (caddr state))\n"
  "(define-constant (compiler-set-bindings! state new-field)\n"
  "  (set-caddr! state new-field))\n"
  "\n"
  "(define-constant (compiler-constant-names state)\n"
  "  (cadddr state))\n"
  "(define-constant (compiler-set-constant-names! state new-field)\n"
  "  (set-cadddr! state new-field))\n"
  "\n"
  ";;; Make it easier to access the second part of the list.\n"
  "(define-constant (compiler-state-second-part state)\n"
  "  (cddddr state))\n"
  "\n"
  "(define-constant (compiler-closures state)\n"
  "  (car (compiler-state-second-part state)))\n"
  "(define-constant (compiler-set-closures! state new-field)\n"
  "  (set-car! (compiler-state-second-part state) new-field))\n"
  "\n"
  "(define-constant (compiler-flags state)\n"
  "  (cadr (compiler-state-second-part state)))\n"
  "(define-constant (compiler-set-flags! state new-field)\n"
  "  (set-cadr! (compiler-state-second-part state) new-field))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiler state: generating instructions.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (compiler-add-instruction! state new-instruction)\n"
  "  (let ((reversed-instructions (compiler-reversed-instructions state)))\n"
  "    (compiler-set-reversed-instructions! state\n"
  "                                         (cons new-instruction\n"
  "                                               reversed-instructions))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiler state: labels.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (compiler-new-label state)\n"
  "  (let* ((old-count (compiler-next-label state)))\n"
  "    (compiler-set-next-label! state (1+ old-count))\n"
  "    old-count))\n"
  "\n"
  ";;; Return a set-of-list of the labels occurring in the given compiler state.\n"
  "(define-constant (compiler-used-labels state)\n"
  "  (let* ((reversed-instructions (compiler-reversed-instructions state))\n"
  "         (label-instructions (filter-reversed (lambda (i) (eq?"" (car i) 'label))\n"
  "                                              reversed-instructions))\n"
  "         (labels (map-reversed cadr label-instructions)))\n"
  "    ;; A sanity check which should be very cheap.  FIXME: possibly remove.\n"
  "    (unless (= (length labels) (length (list->set labels)))\n"
  "      (error `(duplicate labels among ,labels)))\n"
  "    labels))\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiler state: bindings.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; The bindings field of the compiler state is an ordered list (the first\n"
  ";;; binding takes precedence) of elements, each element holding information\n"
  ";;; about where a variable or the closure environment is stored.\n"
  ";;; If the compiled code is alpha-converted then the keys will be unique,\n"
  ";;; but correctness doesn't rely on this.\n"
  ";;;\n"
  ";;; Each binding list element is a cons of one of the following\n"
  ";;; two shapes:\n"
  ";;; - (#t . REGISTER)\n"
  ";;; - (VARIABLE . PLACE)\n"
  ";;; where REGISTER is a non-negative fixnum (the index of register holding\n"
  ";;; the closure environment), VARIABLE is a variable name as a symbol and\n"
  ";;; PLACE has of one of the shapes:\n"
  ";;; - (local-unboxed REGISTER)\n"
  ";;; - (local-boxed REGISTER)\n"
  ";;;      where REGISTER is a fixnum (the register index);\n"
  ";;; - (nonlocal-unboxed INDEX)\n"
  ";;; - (nonlocal-boxed INDEX)\n"
  ";;;      where INDEX is a fixnum (the 0-based index of the matching value in\n"
  ";;;      the closure environment).\n"
  ";;; Globals are not stored in the bindings, but when looked up\n"
  ";;; their PLACE looks like\n"
  ";;; - global\n"
  ";;;      , just a symbol.\n"
  ";;; .\n"
  "\n"
  ";;; Return non-#f iff the given place is a local place, either boxed or unboxed.\n"
  "(define-constant (compiler-place-local?"" place)\n"
  "  (and (cons?"" place)\n"
  "       (or (eq?"" (car place) 'local-boxed)\n"
  "           (eq?"" (car place) 'local-unboxed))))\n"
  "\n"
  ";;; A \"register place\" is either a local or the non-local environment register.\n"
  ";;; Return non-#f iff the given place is a register place.\n"
  "(define-constant (compiler-place-register?"" place)\n"
  "  (or (compiler-place-local?"" place)\n"
  "      (fixnum?"" place)))\n"
  "\n"
  ";;; Return non-#f iff the given place is a nonlocal place, either boxed or\n"
  ";;; unboxed.\n"
  "(define-constant (compiler-place-nonlocal?"" place)\n"
  "  (and (cons?"" place)\n"
  "       (or (eq?"" (car place) 'nonlocal-boxed)\n"
  "           (eq?"" (car place) 'nonlocal-unboxed))))\n"
  "\n"
  ";;; Return non-#f iff the given place is a global place.\n"
  "(define-constant (compiler-place-global?"" place)\n"
  "  (eq?"" place 'global))\n"
  "\n"
  ";;; Given a non-global place as held in the bindings field of a compiler state,\n"
  ";;; return the register index as a fixnum.\n"
  "(define-constant (compiler-place->register place)\n"
  "  (cond ((compiler-place-local?"" place)\n"
  "         ;; Here place must have either the shape (local-unboxed REGISTER-INDEX)\n"
  "         ;; or the shape (local-boxed REGISTER-INDEX) .\n"
  "         (cadr place))\n"
  "        ((fixnum?"" place)\n"
  "         ;; This is the register environment place.\n"
  "         place)\n"
  "        ((eq?"" place 'global)\n"
  "         ;; We don't have a register to return.\n"
  "         (error '(compiler-place->register: globals not supported)))\n"
  "        (else\n"
  "         ;; Nonlocals don't have an associated register.\n"
  "         (error '(compiler-place->register: place ,place supported)))))\n"
  "\n"
  ";;; Return a fresh set-as-list of the register indices used in the given state.\n"
  "(define-constant (compiler-used-registers state)\n"
  "  (let* ((places (map cdr (compiler-bindings state)))\n"
  "         (register-places (filter compiler-place-register?"" places))\n"
  "         (register-list (map! compiler-place->register register-places)))\n"
  "    (list->set register-list)))\n"
  "\n"
  "(define-constant (compiler-fresh-register state)\n"
  "  (let ((used-registers (compiler-used-registers state)))\n"
  "    (compiler-smallest-not-in used-registers)))\n"
  "\n"
  ";;; Return the register index for nonlocals, or error out if none is bound.\n"
  "(define-constant (compiler-nonlocal-register state)\n"
  "  (let ((cons-or-nil (assq #t (compiler-bindings state))))\n"
  "    (if (null?"" cons-or-nil)\n"
  "        (error '(compiler-nonlocal-register: no nonlocal in ,state))\n"
  "        (cdr cons-or-nil))))\n"
  "\n"
  "(define-constant (compiler-bound-variable?"" state variable)\n"
  "  (assq variable (compiler-bindings state)))\n"
  "\n"
  "(define-constant (compiler-lookup-variable state variable)\n"
  "  (let ((cons-or-false (assq variable (compiler-bindings state))))\n"
  "    (if cons-or-false\n"
  "        (cdr cons-or-false)\n"
  "        'global)))\n"
  "\n"
  "(define-constant (compiler-bind! state variable-or-true place)\n"
  "  (let ((bindings (compiler-bindings state)))\n"
  "    (compiler-set-bindings! state\n"
  "                            (cons (cons variable-or-true place)\n"
  "                                  bindings))))\n"
  "\n"
  "(define-constant (compiler-unbind! state variable-or-true)\n"
  "  (let ((bindings (compiler-bindings state))\n"
  "        (place (compiler-lookup-variable state variable-or-true)))\n"
  "    (unless (compiler-place-local?"" place)\n"
  "      ;; It only makes sense to unbind local-unboxed and local-boxed variables.\n"
  "      (error `(cannot unbind ,variable-or-true from ,place)))\n"
  "    (compiler-set-bindings! state\n"
  "                            (del-assq-1-noncopying variable-or-true\n"
  "                                                   bindings))))\n"
  "\n"
  "(define-constant (compiler-bind-local-helper! state variable-name wrapper)\n"
  "  (let* ((register (compiler-fresh-register state))\n"
  "         (place (wrapper register)))\n"
  "    (compiler-bind! state variable-name place)\n"
  "    place))\n"
  "(define-constant (compiler-bind-local-unboxed! state variable-name)\n"
  "  (compiler-bind-local-helper! state\n"
  "                               variable-name\n"
  "                               (lambda (register) `(local-unboxed ,register))))\n"
  "(define-constant (compiler-bind-local-boxed! state variable-name)\n"
  "  (compiler-bind-local-helper! state\n"
  "                               variable-name\n"
  "                               (lambda (register) `(local-boxed ,register))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiler state: known closures.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Add a closure to the set of closures being compiled in the given state.  It\n"
  ";;; is harmless to add the same closure more than once.\n"
  "(define-constant (compiler-add-closure! state closure)\n"
  "  (let* ((old-set (compiler-closures state))\n"
  "         (new-set (set-with old-set closure)))\n"
  "    (compiler-set-closures! state new-set)))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiler state: flags.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; State flags are stored in an alist with unique keys and no default values.\n"
  "\n"
  ";;; The initial flags for a fresh compiler state.\n"
  "(define-constant compiler-flags-default-original\n"
  "  '(;; The tail flag is non-#f iff the AST being compiled is in a tail\n"
  "    ;; context.\n"
  "    (tail . #t)\n"
  "    ;; The used-result flag is non-#f iff the AST being compiled is in a\n"
  "    ;; context where its result will be used; in particular it will be #f\n"
  "    ;; when compiling the first form in a sequence.\n"
  "    ;; Rationale: without using this flag I could always push a #<nothing>\n"
  "    ;; literal at the end of the compilation of forms with unused results, with\n"
  "    ;; the #<nothing> result being correctly dropped by a (drop) instruction\n"
  "    ;; from the compilation of the sequence form.  However it's not always\n"
  "    ;; possible to optimize away those trivial sequences by Jitter-level\n"
  "    ;; rewriting, since the push-literal instruction might not occur immediately\n"
  "    ;; before the drop instruction; that happens frequently with non-tail\n"
  "    ;; conditionals in imperative code.\n"
  "    (used-result . #t)))\n"
  "\n"
  ";;; Return a fresh copy of the compiler default flags.  Since the alist is\n"
  ";;; updated destructively it's important to avoid sharing, both in the spine and\n"
  ";;; in the elements.\n"
  "(define-constant (compiler-flags-default)\n"
  "  (map-reversed (lambda (c) (cons (car c) (cdr c)))\n"
  "                compiler-flags-default-original))\n"
  "\n"
  ";;; Return the value associated to the given key.\n"
  "(define-constant (compiler-flags-get flags name)\n"
  "  (let ((cons-to-read (assq name flags)))\n"
  "    (unless (cons?"" cons-to-read)\n"
  "      (error `(compiler-flags-get: unbound flag ,name)))\n"
  "    (cdr cons-to-read)))\n"
  "\n"
  ";;; Destructivlely update the given flags, setting the given key to the given\n"
  ";;; value.  Error out if the key is not already bound.\n"
  "(define-constant (compiler-flags-set! flags name value)\n"
  "  (let ((cons-to-update (assq name flags)))\n"
  "    (unless (cons?"" cons-to-update)\n"
  "      (error `(compiler-flags-set!: unbound flag ,name)))\n"
  "    (set-cdr! cons-to-update value)))\n"
  "\n"
  ";;; Convenience flag accessors.\n"
  "(define-constant (compiler-flag state flag-name)\n"
  "  (compiler-flags-get (compiler-flags state) flag-name))\n"
  "(define-constant (compiler-set-flag! state flag-name flag-value)\n"
  "  (compiler-flags-set! (compiler-flags state) flag-name flag-value))\n"
  "\n"
  ";;; Convenience flag accessors for specific flags.\n"
  "(define-constant (compiler-tail?"" state)\n"
  "  (compiler-flag state 'tail))\n"
  "(define-constant (compiler-set-tail! state value)\n"
  "  (compiler-set-flag! state 'tail value))\n"
  "(define-constant (compiler-used-result?"" state)\n"
  "  (compiler-flag state 'used-result))\n"
  "(define-constant (compiler-set-used-result! state value)\n"
  "  (compiler-set-flag! state 'used-result value))\n"
  "\n"
  ";;; Execute the given BODY-FORMS with the given compiler FLAG-NAME temporarily\n"
  ";;; changed to FLAG-VALUE in the STATE , then reset FLAG-NAME to its original\n"
  ";;; setting and return the result of the last form.\n"
  ";;; FLAG-NAME must be a symbol, and is not evaluated.\n"
  ";;; I guess this would be a good place to use dynamically-scoped variables,\n"
  ";;; if they existed in JitterLisp.\n"
  "(define-macro (compiler-with-flag state flag-name flag-value . body-forms)\n"
  "  (let ((state-name (gensym))\n"
  "        (outer-value-name (gensym))\n"
  "        (flag-value-name (gensym))\n"
  "        (result-name (gensym)))\n"
  "    `(let* ((,state-name ,state)\n"
  "            (,flag-value-name ,flag-value)\n"
  "            (,outer-value-name (compiler-flag ,state-name ',flag-name)))\n"
  "       (compiler-set-flag! ,state-name ',flag-name ,flag-value-name)\n"
  "       (let ((,result-name ,@body-forms))\n"
  "         (compiler-set-flag! ,state-name ',flag-name ,outer-value-name)\n"
  "         ,result-name))))\n"
  "\n"
  ";;; Temporarily flag changes for specific flags.\n"
  "(define-macro (compiler-with-non-tail state . body-forms)\n"
  "  `(compiler-with-flag ,state tail #f ,@body-forms))\n"
  "(define-macro (compiler-with-used-result state . body-forms)\n"
  "  `(compiler-with-flag ,state used-result #t ,@body-forms))\n"
  "(define-macro (compiler-with-unused-result state . body-forms)\n"
  "  `(compiler-with-flag ,state used-result #f ,@body-forms))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Stuff to move.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-constant (compiler-emit-return-when-tail! s)\n"
  "  (when (compiler-tail?"" s)\n"
  "    (compiler-add-instruction! s '(return))))\n"
  "\n"
  ";;; Generate the appropriate instructions to bind the top of the stack to the\n"
  ";;; given variable, as used free in the given body.  This procedure determines\n"
  ";;; whether the variable needs boxing, no boxing, or no binding whatsoever.\n"
  ";;; Return the place where variable-name is held, or the symbol nowhere .\n"
  "(define-constant (compiler-pop-and-bind! s variable-name body)\n"
  "  (cond ((not (ast-has-free?"" body variable-name))\n"
  "         ;; The variable is not used.\n"
  "         (compiler-add-instruction! s '(drop))\n"
  "         'nowhere)\n"
  "        ((ast-requires-boxing-for?"" body variable-name)\n"
  "         ;; The variable is used and requires boxing.\n"
  "         ;; (compiler-add-instruction! s '(box)) ;; FIXME: I believe this is wrong.  The thing is already boxed, and I don't need a second layer.\n"
  "         (let ((place (compiler-bind-local-boxed! s variable-name)))\n"
  "           (compiler-add-instruction! s `(pop-to-register ,(cadr place)))\n"
  "           place))\n"
  "        (else\n"
  "         ;; The variable is used and doesn't require boxing.\n"
  "         (let ((place (compiler-bind-local-unboxed! s variable-name)))\n"
  "           (compiler-add-instruction! s `(pop-to-register ,(cadr place)))\n"
  "           place))))\n"
  "\n"
  ";; FIXME: factor the compilation of lambda and of existing closures into\n"
  ";; this, if indeed there is anything to factor.\n"
  "(define-constant (compiler-bind-nonlocals! s ?""?""?"" formals body)\n"
  "  (error '(unimplemented: compiler-bind-nonlocals!)))\n"
  "\n"
  ";;; Remove actuals from the stack and bind them to the given formals (here given\n"
  ";;; in the order in which they occur in a lambda, which is the evaluation order\n"
  ";;; -- to be popped right-to-left), simply dropping the ones which are not used\n"
  ";;; in the body.  Also drop the closure, found on the stack below the actuals,\n"
  ";;; and bind nonlocals if needed.\n"
  "(define-constant (compiler-pop-args-and-closure! s formals body)\n"
  "  ;; I have two different implementations of this.\n"
  "  (compiler-pop-args-and-closure!-one-by-one s formals body)\n"
  "  ;;(compiler-pop-args-and-closure!-one-shot s formals body)\n"
  "  )\n"
  "\n"
  ";;; One implementation of compiler-pop-args-and-closure! .  The strategy of this\n"
  ";;; implementation is loading every useful element to registers without\n"
  ";;; affecting the stack, and then dropping everything in one shot.\n"
  ";;; Only one of the implementations is used, but I'm keeping both as I am still\n"
  ";;; undecided about the merits of each.\n"
  "(define-constant (compiler-pop-args-and-closure!-one-shot s formals body)\n"
  "  (let ((formal-no (length formals))\n"
  "        (depth 0)) ;; The depth for the current argument or closure.\n"
  "    (dolist (formal (reverse formals))\n"
  "      (cond ((not (ast-has-free?"" body formal))\n"
  "             ;; The variable is not used.  Do nothing.\n"
  "             )\n"
  "            ((ast-requires-boxing-for?"" body formal)\n"
  "             ;; The variable is used and requires boxing.\n"
  "             (compiler-non-dropping-bind-at-depth! s formal depth #t))\n"
  "            (else\n"
  "             ;; The variable is used and doesn't require boxing.\n"
  "             (compiler-non-dropping-bind-at-depth! s formal depth #f)))\n"
  "      (set! depth (1+ depth)))\n"
  "    ;; The called closure is at depth depth.  Bind the nonlocal environment from\n"
  "    ;; the closure, if needed.\n"
  "    (when (exists?"" (lambda (binding) (compiler-place-nonlocal?"" (cdr binding)))\n"
  "                   (compiler-bindings s))\n"
  "      (let ((register (compiler-fresh-register s)))\n"
  "        (compiler-bind! s #t register)\n"
  "        (if (zero?"" depth)\n"
  "            (compiler-add-instruction! s `(copy-to-register ,register))\n"
  "            (compiler-add-instruction! s `(at-depth-to-register ,depth ,register)))\n"
  "        (compiler-add-instruction! s `(dereference-nonlocals ,register))))\n"
  "    ;; Drop all the actuals plus the closure.\n"
  "    (dotimes (i (+ formal-no 1))\n"
  "      (compiler-add-instruction! s '(drop)))))\n"
  "\n"
  ";;; An alternative implementation of compiler-pop-args-and-closure!, simpler but\n"
  ";;; generating worse code when used and unused arguments are mixed.  On the\n"
  ";;; other hand the VM instructions generated by this implementation are easier\n"
  ";;; to rewrite.\n"
  ";;; A good test case to show the difference:\n"
  ";;;   (define (f a b c d e f g) (+ a c e g))\n"
  ";;; Only one of the implementations is used, but I'm keeping both as I am still\n"
  ";;; undecided about the merits of each.\n"
  "(define-constant (compiler-pop-args-and-closure!-one-by-one s formals body)\n"
  "  (dolist (formal (reverse formals))\n"
  "    (compiler-pop-and-bind! s formal body))\n"
  "  ;; Now the top of the stack contains the called closure.  Bind the nonlocal\n"
  "  ;; environment from the closure, if needed; in either case drop the top\n"
  "  ;; element.\n"
  "  (when (exists?"" (lambda (binding) (compiler-place-nonlocal?"" (cdr binding)))\n"
  "                 (compiler-bindings s))\n"
  "    (let ((register (compiler-fresh-register s)))\n"
  "      (compiler-bind! s #t register)\n"
  "      (compiler-add-instruction! s `(nonlocals-to-register ,register))))\n"
  "  (compiler-add-instruction! s '(drop)))\n"
  "\n"
  ";; Generate an instruction for the given compiler state loading the named\n"
  ";; variable from the stack at the given depth (depth 0 means top), without\n"
  ";; destructively updating the stack; the variable will be boxed if boxed is\n"
  ";; non-#f.  Update the state with the new binding.\n"
  "(define-constant (compiler-non-dropping-bind-at-depth! s name depth boxed)\n"
  "  ;; Determine in which register to hold the variable binding.\n"
  "  (let* ((place (if boxed\n"
  "                    (compiler-bind-local-boxed! s name)\n"
  "                    (compiler-bind-local-unboxed! s name)))\n"
  "         (register (cadr place)))\n"
  "    ;; Generate an instruction loading the register, without modifying the stack.\n"
  "    (if (zero?"" depth)\n"
  "        (compiler-add-instruction! s `(copy-to-register ,register))\n"
  "        (compiler-add-instruction! s `(at-depth-to-register ,depth ,register)))))\n"
  "\n"
  ";;; Generate an instruction pushing a #<nothing> literal.\n"
  "(define-constant (compiler-push-nothing! s)\n"
  "  (compiler-add-instruction! s `(push-literal ,(begin))))\n"
  "\n"
  ";;; Generate instructions saving the contents of the given set-of-list of\n"
  ";;; registers as fixnums, in a conventional order.\n"
  "(define-constant (compiler-save-registers! s registers)\n"
  "  (dolist (register (sort registers))\n"
  "    (compiler-add-instruction! s `(save-register ,register))))\n"
  "\n"
  ";;; Generate instructions saving the contents of the given set-of-list of\n"
  ";;; registers, in a conventional order compatible with (which is to say,\n"
  ";;; opposite to) the instructions generated by compiler-save-registers! .\n"
  "(define-constant (compiler-restore-registers! s registers)\n"
  "  (dolist (register (reverse (sort registers)))\n"
  "    (compiler-add-instruction! s `(restore-register ,register))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiling an AST.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Compile the given AST in the given state.  This works by calling the\n"
  ";;; appropriate helper according to the AST case.\n"
  "(define-constant (compile-ast! s ast)\n"
  "  (cond ((ast-literal?"" ast)\n"
  "         (compile-literal! s (ast-literal-value ast)))\n"
  "        ((ast-variable?"" ast)\n"
  "         (compile-variable! s (ast-variable-name ast)))\n"
  "        ((ast-define?"" ast)\n"
  "         (compile-define s\n"
  "                         (ast-define-name ast)\n"
  "                         (ast-define-body ast)))\n"
  "        ((ast-if?"" ast)\n"
  "         (compile-if! s\n"
  "                      (ast-if-condition ast)\n"
  "                      (ast-if-then ast)\n"
  "                      (ast-if-else ast)))\n"
  "        ((ast-set!?"" ast)\n"
  "         (compile-set!! s\n"
  "                        (ast-set!-name ast)\n"
  "                        (ast-set!-body ast)))\n"
  "        ((ast-while?"" ast)\n"
  "         (compile-while! s\n"
  "                        (ast-while-guard ast)\n"
  "                        (ast-while-body ast)))\n"
  "        ((ast-primitive?"" ast)\n"
  "         (compile-primitive! s\n"
  "                            (ast-primitive-operator ast)\n"
  "                            (ast-primitive-operands ast)))\n"
  "        ((ast-call?"" ast)\n"
  "         (compile-call! s\n"
  "                       (ast-call-operator ast)\n"
  "                       (ast-call-operands ast)))\n"
  "        ((ast-lambda?"" ast)\n"
  "         (compile-lambda! s\n"
  "                         (ast-lambda-formals ast)\n"
  "                         (ast-lambda-body ast)))\n"
  "        ((ast-let?"" ast)\n"
  "         (compile-let! s\n"
  "                      (ast-let-bound-name ast)\n"
  "                      (ast-let-bound-form ast)\n"
  "                      (ast-let-body ast)))\n"
  "        ((ast-sequence?"" ast)\n"
  "         (compile-sequence! s\n"
  "                           (ast-sequence-first ast)\n"
  "                           (ast-sequence-second ast)))))\n"
  "\n"
  "(define-constant (compile-literal! s value)\n"
  "  (when (compiler-used-result?"" s)\n"
  "    (compiler-add-instruction! s `(push-literal ,value))\n"
  "    (compiler-emit-return-when-tail! s)))\n"
  "\n"
  "(define-constant (compile-variable! s name)\n"
  "  (let ((place (compiler-lookup-variable s name)))\n"
  "    (cond ((eq?"" place 'global)\n"
  "           (if (constant?"" name)\n"
  "               (let ((value (symbol-global name)))\n"
  "                 (when (compiler-used-result?"" s)\n"
  "                   (compiler-add-instruction! s `(push-literal ,value))))\n"
  "               (if (compiler-used-result?"" s)\n"
  "                   (compiler-add-instruction! s `(push-global ,name))\n"
  "                   (compiler-add-instruction! s `(check-global-defined ,name)))))\n"
  "          ((compiler-place-local?"" place)\n"
  "           (when (compiler-used-result?"" s)\n"
  "             (compiler-add-instruction! s `(push-register ,(cadr place)))\n"
  "             (when (eq?"" (car place) 'local-boxed)\n"
  "               (compiler-add-instruction! s `(unbox)))))\n"
  "          ((compiler-place-nonlocal?"" place)\n"
  "           (when (compiler-used-result?"" s)\n"
  "             (let ((nonlocal-register (compiler-nonlocal-register s))\n"
  "                   (nonlocal-index (cadr place)))\n"
  "               (compiler-add-instruction! s `(push-register ,nonlocal-register))\n"
  "               (compiler-add-instruction! s `(nonlocal ,nonlocal-index))\n"
  "               (when (eq?"" (car place) 'nonlocal-boxed)\n"
  "                 (compiler-add-instruction! s `(unbox))))))\n"
  "          (else\n"
  "           (error `(unimplemented variable place ,place)))))\n"
  "  (compiler-emit-return-when-tail! s))\n"
  "\n"
  "(define-constant (compile-define s name body)\n"
  "  (compiler-with-non-tail s\n"
  "    (compiler-with-used-result s\n"
  "      (compile-ast! s body)))\n"
  "  (compiler-add-instruction! s `(pop-to-global ,name))\n"
  "  (when (compiler-used-result?"" s)\n"
  "    (compiler-push-nothing! s))\n"
  "  (compiler-emit-return-when-tail! s))\n"
  "\n"
  "(define-constant (compile-if! s condition then else)\n"
  "  (let ((after-then-label (compiler-new-label s))\n"
  "        (after-else-label (compiler-new-label s)))\n"
  "    (compiler-with-non-tail s\n"
  "      (compiler-with-used-result s\n"
  "        (compile-ast! s condition)))\n"
  "    (compiler-add-instruction! s `(branch-if-false ,after-then-label))\n"
  "    (compile-ast! s then)\n"
  "    (unless (compiler-tail?"" s)\n"
  "      (compiler-add-instruction! s `(branch ,after-else-label)))\n"
  "    (compiler-add-instruction! s `(label ,after-then-label))\n"
  "    (compile-ast! s else)\n"
  "    (unless (compiler-tail?"" s)\n"
  "      (compiler-add-instruction! s `(label ,after-else-label)))))\n"
  "\n"
  "(define-constant (compile-set!! s name body)\n"
  "  (let ((place (compiler-lookup-variable s name)))\n"
  "    (compiler-with-non-tail s\n"
  "      (compiler-with-used-result s\n"
  "        (compile-ast! s body)))\n"
  "    (cond ((compiler-place-global?"" place)\n"
  "           (compiler-add-instruction! s `(pop-to-global-defined ,name)))\n"
  "          ((eq?"" (car place) 'local-unboxed)\n"
  "           (compiler-add-instruction! s `(pop-to-register ,(cadr place))))\n"
  "          ((eq?"" (car place) 'local-boxed)\n"
  "           (compiler-add-instruction! s `(pop-to-register-box ,(cadr place))))\n"
  "          ((eq?"" (car place) 'nonlocal-unboxed)\n"
  "           (error `(compile-set!!: ,name is nonlocal-unboxed but is assigned)))\n"
  "          ((eq?"" (car place) 'nonlocal-boxed)\n"
  "           (let ((nonlocal-register (compiler-nonlocal-register s))\n"
  "                 (index (cadr place)))\n"
  "             (compiler-add-instruction! s `(push-register ,nonlocal-register))\n"
  "             (compiler-add-instruction! s `(set-nonlocal ,index))))\n"
  "          (else\n"
  "           (error `(unsupported set! place ,place)))))\n"
  "  (when (compiler-used-result?"" s)\n"
  "    (compiler-push-nothing! s))\n"
  "  (compiler-emit-return-when-tail! s))\n"
  "\n"
  "(define-constant (compile-infinite-loop! s body)\n"
  "  (let ((before-body-label (compiler-new-label s)))\n"
  "    (compiler-add-instruction! s `(label ,before-body-label))\n"
  "    (compiler-with-non-tail s\n"
  "      (compiler-with-unused-result s\n"
  "        (compile-ast! s body)))\n"
  "    (compiler-add-instruction! s `(branch ,before-body-label))\n"
  "    ;; At this point I would normally emit one instruction to push #<nothing>\n"
  "    ;; when the result is used, and a return when the context is tail; but in\n"
  "    ;; this case they would be unreachable after an infinite loop.\n"
  "    ))\n"
  "\n"
  "(define-constant (compile-while-ordinary! s guard body)\n"
  "  (let ((before-body-label (compiler-new-label s))\n"
  "        (before-guard-label (compiler-new-label s)))\n"
  "    (compiler-add-instruction! s `(branch ,before-guard-label))\n"
  "    (compiler-add-instruction! s `(label ,before-body-label))\n"
  "    (compiler-with-non-tail s\n"
  "      (compiler-with-unused-result s\n"
  "        (compile-ast! s body)))\n"
  "    (compiler-add-instruction! s `(label ,before-guard-label))\n"
  "    (compiler-with-non-tail s\n"
  "      (compiler-with-used-result s\n"
  "        (compile-ast! s guard)))\n"
  "    (compiler-add-instruction! s `(branch-if-true ,before-body-label)))\n"
  "  (when (compiler-used-result?"" s)\n"
  "    (compiler-push-nothing! s))\n"
  "  (compiler-emit-return-when-tail! s))\n"
  "\n"
  "(define-constant (compile-while! s guard body)\n"
  "  (if (and (ast-literal?"" guard)\n"
  "           (ast-literal-value guard))\n"
  "      (compile-infinite-loop! s body)\n"
  "      (compile-while-ordinary! s guard body)))\n"
  "\n"
  "(define-constant (compile-primitive! s operator operands)\n"
  "  (dolist (operand operands)\n"
  "    (compiler-with-non-tail s\n"
  "      (compiler-with-used-result s\n"
  "        (compile-ast! s operand))))\n"
  "  (compiler-add-instruction! s `(primitive ,operator))\n"
  "  (unless (compiler-used-result?"" s)\n"
  "    (compiler-add-instruction! s '(drop)))\n"
  "  (compiler-emit-return-when-tail! s))\n"
  "\n"
  "(define-constant (compile-call! s operator operands)\n"
  "  (let* ((literal-closure-operator\n"
  "          ;; Non-#f iff the operator is a literal closure.\n"
  "          (and (ast-literal?"" operator)\n"
  "               (closure?"" (ast-literal-value operator))))\n"
  "         (global-constant-operator\n"
  "          ;; Non-#f iff the operator is a non-shadowed global bound to a\n"
  "          ;; constant.\n"
  "          (and (ast-variable?"" operator)\n"
  "               (not (compiler-bound-variable?"" s (ast-variable-name operator)))\n"
  "               (constant?"" (ast-variable-name operator))))\n"
  "         (known-closure\n"
  "          ;; Bind known-closure to the called closure if I can resolve it at\n"
  "          ;; this time, otherwise to #f.\n"
  "          (cond (literal-closure-operator\n"
  "                 ;; The operator is a literal closure.\n"
  "                 (ast-literal-value operator))\n"
  "                (global-constant-operator\n"
  "                 ;; The operator is a variable globally bound to a constant\n"
  "                 ;; and not shadowed.\n"
  "                 (symbol-global (ast-variable-name operator)))\n"
  "                (else\n"
  "                 ;; The closure is not known: I can't omit run-time checks.\n"
  "                 #f)))\n"
  "         (known-compiled\n"
  "          ;; Non-#f iff the closure is known to be compiled.  This can happen\n"
  "          ;; as long as we know the operator to be a closure, in three cases:\n"
  "          (and known-closure\n"
  "               (or ;; (a) I already know what the compiled closure is...\n"
  "                   (compiled-closure?"" known-closure)\n"
  "                   ;; (b) I know that the operator is the unshadowed global constant\n"
  "                   ;;     name of a global being compiled.\n"
  "                   (and global-constant-operator\n"
  "                        (set-has?"" (compiler-constant-names s)\n"
  "                                  (ast-variable-name operator)))\n"
  "                   ;; (c) The operator is a literal interpreted closure which is\n"
  "                   ;;     being compiled now, and therefore counts as if it were\n"
  "                   ;;     already compiled when called.\n"
  "                   (and literal-closure-operator\n"
  "                        (set-has?"" (compiler-closures s)\n"
  "                                  (ast-literal-value operator))))))\n"
  "         (tail (compiler-tail?"" s))\n"
  "         (call-instruction\n"
  "          ;; The VM instruction to use for calling.\n"
  "          (cond ((and known-compiled tail)\n"
  "                 'tail-call-compiled)\n"
  "                (tail\n"
  "                 'tail-call)\n"
  "                (known-compiled\n"
  "                 'call-compiled)\n"
  "                (else\n"
  "                 'call))))\n"
  "    (compiler-with-non-tail s\n"
  "      (compiler-with-used-result s\n"
  "        (compile-ast! s operator)))\n"
  "    (unless known-closure\n"
  "      (compiler-add-instruction! s `(check-closure)))\n"
  "    (unless (and known-closure\n"
  "                 (= (closure-in-arity known-closure) (length operands)))\n"
  "      (when known-closure\n"
  "        ;; FIXME: warn more cleanly.\n"
  "        (display `(WARNING: in-arity mismatch in call to known closure\n"
  "                            ,operator with actuals ,operands))\n"
  "        (newline))\n"
  "      (compiler-add-instruction! s `(check-in-arity ,(length operands))))\n"
  "    (dolist (operand operands)\n"
  "      (compiler-with-non-tail s\n"
  "                              (compiler-with-used-result s\n"
  "                                                         (compile-ast! s operand))))\n"
  "    (if (compiler-tail?"" s)\n"
  "        (compiler-add-instruction! s `(,call-instruction ,(length operands)))\n"
  "        (let ((used-registers (compiler-used-registers s)))\n"
  "          ;; The registers being used at this point are a superset of the ones\n"
  "          ;; live at return.  This is a conservative approximation, crude but\n"
  "          ;; correct.  Doing better would require a liveness analysis pass.\n"
  "          (compiler-save-registers! s used-registers)\n"
  "          (compiler-add-instruction! s `(,call-instruction ,(length operands)))\n"
  "          (compiler-restore-registers! s used-registers)\n"
  "          (unless (compiler-used-result?"" s)\n"
  "            (compiler-add-instruction! s '(drop)))))))\n"
  "\n"
  "(define-constant (compile-let! s bound-name bound-form body)\n"
  "  (compiler-with-non-tail s\n"
  "    (compiler-with-used-result s\n"
  "      (compile-ast! s bound-form)))\n"
  "  (let ((place (compiler-pop-and-bind! s bound-name body)))\n"
  "    (compile-ast! s body)\n"
  "    (unless (eq?"" place 'nowhere)\n"
  "      (compiler-unbind! s bound-name))))\n"
  "\n"
  "(define-constant (compile-lambda! s formals body)\n"
  "  (when (compiler-used-result?"" s)\n"
  "    (error '(unimplemented: compile-lambda!))\n"
  "    (compiler-emit-return-when-tail! s)))\n"
  "\n"
  "(define-constant (compile-sequence! s first second)\n"
  "  (compiler-with-non-tail s\n"
  "    (compiler-with-unused-result s\n"
  "      (compile-ast! s first)))\n"
  "  (compile-ast! s second))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiling an interpreted closure.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Compiling an interpreted closure destructively changes it into a compiled\n"
  ";;; closure, without affecting its identity.  The change is irreversible: an\n"
  ";;; interpreted closure can become compiled, but it's not possible to uncompile\n"
  ";;; a compiled closure.\n"
  "\n"
  ";;; Compile the given closure, knowing the that given set-as-list of symbols are\n"
  ";;; global names of constant closures being compiled, possibly including c ,\n"
  ";;; and that the given set-of-list of closures are also being compiled (again,\n"
  ";;; possibly including the global value of c).\n"
  ";;; Rationale: independently from the order of compilation, the compiled will be\n"
  ";;; able to assume that any (free) call from c to one of the named procedures\n"
  ";;; will be to a compiled procedure: this saves a conditional per call at\n"
  ";;; execution time.\n"
  ";;; It would be possible to do even better by compiling every closure in one go,\n"
  ";;; and directly refer compiled code instead of symbols.\n"
  "(define-constant (interpreted-closure-compile!-knowing\n"
  "                     c\n"
  "                     constant-names-being-compiled\n"
  "                     closures-being-compiled)\n"
  "  ;; Validate arguments.\n"
  "  (when (compiled-closure?"" c)\n"
  "    (error `(closure ,c is already compiled)))\n"
  "  (dolist (name constant-names-being-compiled)\n"
  "    (unless (symbol?"" name)\n"
  "      (error `(name for constant closure being compiled not a symbol: ,name)))\n"
  "    (unless (defined?"" name)\n"
  "      (error `(name for constant closure being compiled not globally bound:\n"
  "                    ,name)))\n"
  "    (unless (constant?"" name)\n"
  "      (error `(named constant closure being compiled not constant: ,name)))\n"
  "    (unless (interpreted-closure?"" (symbol-global name))\n"
  "      (error `(named constant closure being compiled not an interpreted\n"
  "                    closure: ,name))))\n"
  "  (let ((env (interpreted-closure-environment c))\n"
  "        (formals (interpreted-closure-formals c))\n"
  "        (body (interpreted-closure-body c)))\n"
  "    (let ((s (compiler-make-state))\n"
  "          (next-nonlocal-index 0)\n"
  "          (bound-nonlocal-names set-empty)\n"
  "          (reversed-nonlocal-values ()))\n"
  "      ;; Record the names of the constant closures being compiled, and their\n"
  "      ;; values.\n"
  "      (compiler-set-constant-names! s constant-names-being-compiled)\n"
  "      (dolist (name constant-names-being-compiled)\n"
  "        (compiler-add-closure! s (symbol-global name)))\n"
  "      (dolist (closure closures-being-compiled)\n"
  "              (compiler-add-closure! s closure))\n"
  "      ;; Of course we are compiling the current closures.  Adding it to the\n"
  "      ;; set of known-to-be-compiled closures will let the compiler generate\n"
  "      ;; better code for recursive calls via literal operators.\n"
  "      (compiler-add-closure! s c)\n"
  "      ;; Emit the procedure prolog.\n"
  "      (compiler-add-instruction! s '(procedure-prolog))\n"
  "      ;; Bind every nonlocal which is not shadowed by a formal and which is\n"
  "      ;; actually used.\n"
  "      ;; Since here we are compiling an existing interpreted closure which used\n"
  "      ;; boxing for every nonlocal we will use boxing in the compiled version as\n"
  "      ;; well: there is no way of knowing which nonlocal actually needs boxing\n"
  "      ;; to be shared correctly with other code.\n"
  "      ;; Ignore non-local occurrences of already bound non-locals: only the\n"
  "      ;; first binding counts for each variable, since what we find first\n"
  "      ;; has been bound in the innermost context.\n"
  "      (dolist (env-binding env)\n"
  "        (when (and (not (set-has?"" formals (car env-binding)))\n"
  "                   (not (set-has?"" bound-nonlocal-names (car env-binding)))\n"
  "                   (ast-has-free?"" body (car env-binding)))\n"
  "          (compiler-bind! s\n"
  "                          (car env-binding)\n"
  "                          `(nonlocal-boxed ,next-nonlocal-index))\n"
  "          (set! next-nonlocal-index (+ next-nonlocal-index 1))\n"
  "          (set! reversed-nonlocal-values\n"
  "                (cons (cdr env-binding)\n"
  "                      reversed-nonlocal-values))))\n"
  "      (cond ((closure-primitive-wrapper?"" c)\n"
  "             ;; Special case: we are compiling a primitive wrapper.\n"
  "             (let ((primitive (ast-primitive-operator body)))\n"
  "               ;; We can compile primitive wrappers (see the definition above)\n"
  "               ;; in a more efficient way: primitive, nip, return.\n"
  "               (compiler-add-instruction! s `(primitive ,primitive))\n"
  "               (compiler-add-instruction! s '(nip))\n"
  "               (compiler-add-instruction! s '(return))))\n"
  "            (else\n"
  "             ;; General case.\n"
  "             ;; Generate code binding the formals we use and the nonlocals in\n"
  "             ;; registers, ignoring the others and dropping them all, including\n"
  "             ;; the closure argument.\n"
  "             (compiler-pop-args-and-closure! s formals body)\n"
  "             ;; Now the state contains bindings for every non-global bound in\n"
  "             ;; the body AST, and we can compile it.  Any remaining variable\n"
  "             ;; occurring in the body but not in the state bindings is a global.\n"
  "             (compile-ast! s body)))\n"
  "      ;;(print-compiler-state s)\n"
  "      ;; We can now destructively modify the interpreted closure.\n"
  "      (interpreted-closure-make-compiled!\n"
  "          c\n"
  "          (length formals)\n"
  "          (reverse! reversed-nonlocal-values)\n"
  "          (reverse! (compiler-reversed-instructions s)))\n"
  ";;(newline) (disassemble-procedure c) (newline)\n"
  "      )))\n"
  "\n"
  ";;; A convenient procedure to call when one closure is being compiled in\n"
  ";;; isolation.\n"
  "(define-constant (interpreted-closure-compile!-procedure c)\n"
  "  (interpreted-closure-compile!-knowing c () ()))\n"
  "(define-macro (interpreted-closure-compile! . closures)\n"
  "  `(map-syntactically interpreted-closure-compile!-procedure ,@closures))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiliation convenience procedures.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; It's nice to provide the user with procedures working indifferently on\n"
  ";;; interpreted or compiled closures, compiling the intepreted ones on the fly\n"
  ";;; if needed.\n"
  "\n"
  ";;; This factors the common functionality of the user procedures below.\n"
  "(define-constant (compile!-if-needed-then-call thing procedure)\n"
  "  (cond ((compiled-closure?"" thing)\n"
  "         ;; The thing is already compiled.\n"
  "         (procedure thing))\n"
  "        ((interpreted-closure?"" thing)\n"
  "         ;; The thing is not compiled yet.  Optimize it and compile it, then do\n"
  "         ;; the job.\n"
  "         (interpreted-closure-optimize! thing)\n"
  "         (interpreted-closure-compile! thing)\n"
  "         (procedure thing))\n"
  "        ((symbol?"" thing)\n"
  "         ;; This is a name, hopefully for a closure.\n"
  "         (let ((names (if (and (defined?"" thing)\n"
  "                               (constant?"" thing))\n"
  "                          (list thing)\n"
  "                          ()))\n"
  "               (c (symbol-global thing)))\n"
  "           ;; Optimize the closure and compile it; if it's a global constant\n"
  "           ;; we can use its name during compilation, to compile recursive\n"
  "           ;; calls more efficiently.\n"
  "           (interpreted-closure-optimize! c)\n"
  "           (interpreted-closure-compile!-knowing c names ())))\n"
  "        ((macro?"" thing)\n"
  "         ;; Macros are only interpreted.  This is a current limitation that\n"
  "         ;; could be lifted.\n"
  "         (error `(macros not currently compilable: ,thing)))\n"
  "        (else\n"
  "         ;; This is a non-closure non-macro.\n"
  "         (error `(cannot compile ,thing)))))\n"
  "\n"
  ";;; Compile the given closure if needed.  Return nothing.\n"
  "(define-constant (compile!-procedure thing)\n"
  "  (compile!-if-needed-then-call thing (lambda (unused))))\n"
  "(define-macro (compile! . things)\n"
  "  `(map-syntactically compile!-procedure ,@things))\n"
  "\n"
  ";; FIXME: generalize the procedures above to compiling a list or set of closures\n"
  ";; all at the same time.  This will make inter-calls more efficient.\n"
  "\n"
  ";;; Print a native-code disassembly of the given closure, compiling it first if\n"
  ";;; needed.  Return nothing.\n"
  "(define-constant (disassemble-procedure thing)\n"
  "  (compile!-if-needed-then-call thing compiled-closure-disassemble))\n"
  "(define-macro (disassemble . things)\n"
  "  `(map-syntactically disassemble-procedure ,@things))\n"
  "\n"
  ";;; Print VM code for the given closure, compiling it first if needed.  Return\n"
  ";;; nothing.\n"
  "(define-constant (disassemble-vm-procedure thing)\n"
  "  (compile!-if-needed-then-call thing compiled-closure-print))\n"
  "(define-macro (disassemble-vm . things)\n"
  "  `(map-syntactically disassemble-vm-procedure ,@things))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Compiler scratch code.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; Scratch, for debugging.\n"
  "(define-constant (print-reversed-instructions xs)\n"
  "  (dolist (x (reverse xs))\n"
  "    (when (and (list?"" x)\n"
  "               (not-eq?"" (car x) 'label))\n"
  "      (dotimes (i 4)\n"
  "        (character-display #\\space)))\n"
  "    (display x)\n"
  "    (newline)))\n"
  "\n"
  ";;; A debugging procedure.\n"
  "(define-constant (print-compiler-state s)\n"
  "  (display `(USED LABELS: ,@(sort (compiler-used-labels s))))\n"
  "  (newline)\n"
  "  (print-reversed-instructions (compiler-reversed-instructions s)))\n"
  "\n"
  ";; Temporary testing procedure: unoptimized version.\n"
  "(define (tup ast)\n"
  "  (let ((s (compiler-make-state)))\n"
  "    (display 'ast:) (dotimes (i 1) (character-display #\\space))\n"
  "    (display ast)\n"
  "    (newline)\n"
  "    (compile-ast! s ast)\n"
  "    (print-compiler-state s)\n"
  "    (newline)))\n"
  "\n"
  ";; Temporary testing procedure: optimized version.\n"
  "(define (top ast)\n"
  "  (let ((s (compiler-make-state))\n"
  "        (optimized-ast (ast-optimize ast ())))\n"
  "    (display 'original:) (dotimes (i 2) (character-display #\\space))\n"
  "    (display ast)\n"
  "    (newline)\n"
  "    (display 'rewritten:) (dotimes (i 1) (character-display #\\space))\n"
  "    (display optimized-ast)\n"
  "    (newline)\n"
  "    (compile-ast! s optimized-ast)\n"
  "    (print-compiler-state s)\n"
  "    (newline)))\n"
  "\n"
  ";; Temporary testing macro: unoptimized.\n"
  "(define-macro (tu . forms)\n"
  "  `(tup (macroexpand '(begin ,@forms))))\n"
  "\n"
  ";; Temporary testing macro: optimized.\n"
  "(define-macro (to . forms)\n"
  "  `(top (macroexpand '(begin ,@forms))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Implicit optimization: definitions.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; From now on definition forms will automatically optimize new globally bound\n"
  ";;; closures.\n"
  "\n"
  ";;; Keep the previous (macro) values for define and define-constant forms .\n"
  "(define define-non-optimized\n"
  "  define)\n"
  "(define define-constant-non-optimized\n"
  "  define-constant)\n"
  "\n"
  ";;; Destructively optimize the argument if it's an interpreted closure; do\n"
  ";;; nothing otherwise.  Return nothing.\n"
  "(define-constant (optimize-when-interpreted-closure! thing)\n"
  "  (when (interpreted-closure?"" thing)\n"
  "    (interpreted-closure-optimize! thing)))\n"
  "\n"
  ";;; Define the named thing, and immediately optimize it if it's a closure.  Same\n"
  ";;; syntax as define.\n"
  "(define-macro (define-optimized-possibly-constant constant thing . body)\n"
  "  (cond ((symbol?"" thing)\n"
  "         (let ((value-name (gensym)))\n"
  "           `(let ((,value-name ,@body))\n"
  "              (define-non-optimized ,thing ,value-name)\n"
  "              (when ,constant\n"
  "                ;; Making a globally defined closure a constant *before*\n"
  "                ;; optimizing it may help the rewrite system.\n"
  "                (make-constant! ',thing))\n"
  "              (optimize-when-interpreted-closure! ,value-name))))\n"
  "        ((or (not (symbols?"" thing))\n"
  "             (not (all-different?"" (cdr thing))))\n"
  "         (error `(define-optimized-possibly-constant: ill-formed defined\n"
  "                   thing ,thing)))\n"
  "        (else\n"
  "         (let ((value-name (gensym))\n"
  "               (thing-name (car thing))\n"
  "               (thing-formals (cdr thing)))\n"
  "           `(let ((,value-name (lambda ,thing-formals\n"
  "                                 ,@body)))\n"
  "              (define-non-optimized ,thing-name ,value-name)\n"
  "              (when ,constant\n"
  "                ;; Again, make the thing constant before optimizing it.\n"
  "                (make-constant! ',thing-name))\n"
  "              (optimize-when-interpreted-closure! ,value-name))))))\n"
  "(define-macro (define-optimized thing . body)\n"
  "  `(define-optimized-possibly-constant #f ,thing ,@body))\n"
  "(define-macro (define-constant-optimized thing . body)\n"
  "  `(define-optimized-possibly-constant #t ,thing ,@body))\n"
  "\n"
  ";; Re-define define and define-constant to make them implicitly optimizing.\n"
  "(define-macro (define thing . body)\n"
  "  `(define-optimized ,thing ,@body))\n"
  "(define-macro (define-constant thing . body)\n"
  "  `(define-constant-optimized ,thing ,@body))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  ";;;; The library is now loaded.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; This is checked at startup to error out in case the library is being loaded\n"
  ";;; more than once.  Make the defined symbol constant, so that it can't be\n"
  ";;; undefined.\n"
  "(define-constant jitterlisp-library-loaded\n"
  "  #t)\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Tentative: variadic map.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  ";;; This macro factors the common code for the variadic versions of map-reversed\n"
  ";;; and map! .  List reversal is not performed here, so the variadic version of\n"
  ";;; map will use the variadic version of map-reversed , and then tail-call\n"
  ";;; reverse! to destructively update the temporary list and turn it into the\n"
  ";;; result.  map! needs no reversal.\n"
  ";;;\n"
  ";;; operator is \"applied\" in the sense of being copied into a list car in the\n"
  ";;; expansion, independently from its type.  The exansion of this macro does not\n"
  ";;; evaluate it.  Rationale: user macros relying on this one will evaluate the\n"
  ";;; user operator and check its type: if the given operator is a macro they will\n"
  ";;; call this macro with the operator name; otherwise, assuming the operator is\n"
  ";;; a closure, they will pass the closure value.\n"
  "(define-macro (vmap-internal destructive operator . lists)\n"
  "  (unless (list?"" lists)\n"
  "    (error `(vmap-internal: non-list lists argument: ,lists)))\n"
  "  (unless (non-null?"" lists)\n"
  "    (error `(vmap-internal: zero lists given)))\n"
  "  (let* ((list-no (length lists))\n"
  "         (list-names (map (lambda (whatever) (gensym))\n"
  "                          lists))\n"
  "         (first-list-name (car list-names))\n"
  "         (result-name (gensym)))\n"
  "    `(let* (,@(map (lambda (name-list) (list (car name-list) (cdr name-list)))\n"
  "                   (zip list-names lists))\n"
  "            (,result-name ,(if destructive\n"
  "                               first-list-name\n"
  "                               ())))\n"
  "       (while (non-null?"" ,first-list-name)\n"
  "         ,(if destructive\n"
  "              `(set-car! ,first-list-name\n"
  "                         (,operator ,@(map (lambda (list-name) `(car ,list-name))\n"
  "                                           list-names)))\n"
  "              `(set! ,result-name\n"
  "                     (cons (,operator ,@(map (lambda (list-name) `(car ,list-name))\n"
  "                                             list-names))\n"
  "                           ,result-name)))\n"
  "         ,@(map (lambda (list-name) `(set! ,list-name (cdr ,list-name)))\n"
  "                list-names))\n"
  "       ,@(map (lambda (list-name)\n"
  "                `(unless (null?"" ,list-name)\n"
  "                   (error '(vmap-internal: first list shorter than at least other one))))\n"
  "              (cdr list-names))\n"
  "       ,result-name)))\n"
  "\n"
  ";;; FIXME: describe these in comments and document them in the manual.  They are easy.\n"
  "\n"
  "(define-macro (vmap-reversed operator . lists)\n"
  "  (let ((operator-value operator))\n"
  "    (if (macro?"" operator-value)\n"
  "        `(vmap-internal #f ,operator ,@lists)\n"
  "        `(vmap-internal #f ,operator-value ,@lists))))\n"
  "\n"
  "(define-macro (vmap operator . lists)\n"
  "  `(reverse! (vmap-reversed ,operator ,@lists)))\n"
  "\n"
  "(define-macro (vmap! operator . lists)\n"
  "  (let ((operator-value operator))\n"
  "    (if (macro?"" operator-value)\n"
  "        `(vmap-internal #t ,operator ,@lists)\n"
  "        `(vmap-internal #t ,operator-value ,@lists))))\n"
  "\n"
  "\n"
  "\n"
  "\n"
  ";;;; Scratch.\n"
  ";;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
  "\n"
  "(define-macro (c lambda)\n"
  "  (let ((closure-name (gensym)))\n"
  "    `(let ((,closure-name ,lambda))\n"
  "       (interpreted-closure-optimize! ,closure-name)\n"
  "       (interpreted-closure-compile! ,closure-name)\n"
  "       (newline)\n"
  "       (compiled-closure-print ,closure-name)\n"
  "       (newline)\n"
  "       (compiled-closure-disassemble ,closure-name))))\n"
  "\n"
  ";;; This is useful to test run-time type checking, particularly in compiled\n"
  ";;; code.\n"
  "(define-constant (count-i-incorrect a)\n"
  "  (while (not (zero?"" a))\n"
  "    (set! a (- a 'b)))\n"
  "  a)\n"
  "\n"
  "(define-constant (average-procedure a b)\n"
  "  (/ (+ a b) 2))\n"
  "\n"
  "(define-macro (average . things)\n"
  "  (when (zero?"" (length things))\n"
  "    (error '(average: zero arguments)))\n"
  "  `(/ (+ ,@things)\n"
  "      ,(length things)))\n"
  "\n"
  "(define (sum xs)\n"
  "  (let ((res 0))\n"
  "    (while (not (null?"" xs))\n"
  "      (set! res (+ res (car xs)))\n"
  "      (set! xs (cdr xs))) res))\n"
  "\n"
  "(define (qq n)\n"
  "  (length (flatten (map iota (iota n)))))\n"
  "\n"
  "(define-constant (make-tree depth)\n"
  "  (if (zero?"" depth)\n"
  "      ()\n"
  "      (let ((branch (make-tree (- depth 1))))\n"
  "        (cons branch branch))))\n"
  "\n"
  "(define-constant (complexity-non-tail-recursive thing)\n"
  "  (if (cons?"" thing)\n"
  "      (+ 1\n"
  "         (complexity-non-tail-recursive (car thing))\n"
  "         (complexity-non-tail-recursive (cdr thing)))\n"
  "      1))\n"
  "\n"
  "(define-constant (complexity-tail-recursive thing)\n"
  "  (complexity-tail-recursive-helper (list thing) 0))\n"
  "(define-constant (complexity-tail-recursive-helper worklist acc)\n"
  "  (cond ((null?"" worklist)\n"
  "         acc)\n"
  "        ((cons?"" (car worklist))\n"
  "         (let ((first (car worklist)))\n"
  "           (complexity-tail-recursive-helper (cons (car first)\n"
  "                                                   (cons (cdr first)\n"
  "                                                         (cdr worklist)))\n"
  "                                             (+ acc 1))))\n"
  "        (else\n"
  "         (complexity-tail-recursive-helper (cdr worklist) (+ acc 1)))))\n"
  "\n"
  "(define-constant (complexity-iterative thing)\n"
  "  (let ((res 0)\n"
  "        (worklist (list thing)))\n"
  "    (while (not (null?"" worklist))\n"
  "      (let ((first (car worklist)))\n"
  "        (set! res (+ res 1))\n"
  "        (if (cons?"" first)\n"
  "            (begin\n"
  "              (set-car! worklist (cdr first))\n"
  "              (set! worklist (cons (car first) worklist)))\n"
  "            (set! worklist (cdr worklist)))))\n"
  "    res))\n"
  "\n"
  "(define-constant (even?""-tr n)\n"
  "  (cond ((zero?"" n)\n"
  "         #t)\n"
  "        ((= n 1)\n"
  "         #f)\n"
  "        (else\n"
  "         (odd?""-tr (- n 1)))))\n"
  "(define-constant (odd?""-tr n)\n"
  "  (cond ((zero?"" n)\n"
  "         #f)\n"
  "        ((= n 1)\n"
  "         #t)\n"
  "        (else\n"
  "         (even?""-tr (- n 1)))))\n"
  "\n"
  "\n"
  "(define-constant (sign n)\n"
  "  (cond ((zero?"" n) 0)\n"
  "        ((< n 0)   -1)\n"
  "        (else      1)))\n"
  "\n"
  "(define (interpreted-closure-names)\n"
  "  (filter (lambda (s)\n"
  "            (and (defined?"" s)\n"
  "                 (interpreted-closure?"" (symbol-global s))))\n"
  "          (interned-symbols)))\n"
  "\n"
  "(define (compile-all-sequentially!)\n"
  "  (dolist (s (interpreted-closure-names))\n"
  "    (display `(compiling ,s))\n"
  "    (newline)\n"
  "    (compile! (symbol-global s))))\n"
  "\n"
  "(define-macro (compile-all!)\n"
  "  (let ((interpreted-closure-names (interpreted-closure-names)))\n"
  "    `(begin\n"
  "       (display '(compiling ,(length interpreted-closure-names) procedures in one shot))\n"
  "       (newline)\n"
  "       (compile! ,@interpreted-closure-names))))\n"
  "\n"
  "(define-constant (prime?"" n)\n"
  "  (if (< n 2)\n"
  "      #f\n"
  "      (let ((i 2)\n"
  "            (divisor-found #f))\n"
  "        (while (and (not divisor-found)\n"
  "                    (< i n))\n"
  "               (when (zero?"" (remainder n i))\n"
  "                 (set! divisor-found #t))\n"
  "               (set! i (+ i 1)))\n"
  "        (not divisor-found))))\n"
  "\n"
  "(define-constant (primes-naif limit)\n"
  "  (let ((reversed-res ()))\n"
  "    (dotimes (i limit)\n"
  "      (when (prime?"" i)\n"
  "        (set! reversed-res (cons i reversed-res))))\n"
  "    (reverse! reversed-res)))\n"
  "\n"
  "(define-constant (prime?""-knowing known-primes n)\n"
  "  (if (< n 2)\n"
  "      #f\n"
  "      (let ((i 2)\n"
  "            (remaining-candidate-factors known-primes)\n"
  "            (divisor-found #f))\n"
  "        (while (and (not divisor-found)\n"
  "                    (not (null?"" remaining-candidate-factors)))\n"
  "               (when (zero?"" (remainder n (car remaining-candidate-factors)))\n"
  "                 (set! divisor-found #t))\n"
  "               (set! remaining-candidate-factors\n"
  "                     (cdr remaining-candidate-factors)))\n"
  "        (not divisor-found))))\n"
  "\n"
  "(define-constant (primes limit)\n"
  "  (let ((known-primes ()))\n"
  "    (dotimes (i limit)\n"
  "      (when (prime?""-knowing known-primes i)\n"
  "        (set! known-primes (cons i known-primes))))\n"
  "    (reverse! known-primes)))\n"
  "\n"
  ";;; FIXME: these are good for testing return with defective instructions.\n"
  "(define-constant (fibo-tr next-to-last last n) (if (zero?"" n) next-to-last (fibo-tr last (+ next-to-last last) (- n 1))))\n"
  "(define-constant (fibof n) (fibo-tr 0 1 n))\n"
  "(define-constant (fibor n) (if (< n 2) n (+ (fibor (- n 2)) (fibor (- n 1)))))\n"
  "\n"
  "(define-macro (compiled-lambda formals . body)\n"
  "  (let ((closure-name (gensym)))\n"
  "    `(let ((,closure-name (lambda ,formals ,@body)))\n"
  "       (compile! ,closure-name)\n"
  "       ,closure-name)))\n"
  "\n"
  ";;; I CAN DO BETTER IN THIS CASE:\n"
  ";;; (lambda (f x) (f (begin y x)))\n"
  ";;; Getting this right in the general case (any number of arguments, both\n"
  ";;; procedures and primitives) would improve the quality of inlined code.\n"
  ";;; The first expression in the sequence, here y, is allowed to have effects.\n"
  "\n"
  ";;;  OK\n"
  ";;; (define q (macroexpand '(let ((a a) (b a)) a))) q (ast-alpha-convert q)\n"
  ";;; (define q (macroexpand '(f x (+ 2 3)))) q (ast-optimize q ())\n"
  "\n"
  ";;; OK\n"
  ";;; (ast-optimize (macroexpand '(cons 3 (begin2 (define-non-optimized x y) x 7))) ())\n"
  ";;; [primitive #<2-ary primitive cons> [literal 3] [sequence [define x [variable y]] [variable x]]]\n"
  "\n"
  ";;; OK\n"
  ";;; (ast-optimize (macroexpand '(cons 3 (begin2 (define x y) x 7))) '(x))\n"
  ";;; [sequence [define x [variable y]] [primitive #<2-ary primitive cons> [literal 3] [variable x]]]\n"
  "\n"
  ";;; An important test:\n"
  ";;; (ast-optimize (closure-body fibo) '(n))\n"
  "\n"
  ";;; Something which should get smaller:\n"
  ";;; (ast-optimize (closure-body ast-simplify-calls) '(ast))\n"
  "\n"
  ";;; These are interesting because of the sequence in the let bound form:\n"
  ";;; ACCEPTABLE(ast-optimize (macroexpand '(cons 3 (begin x 7))) ())\n"
  ";;; GOOD(ast-optimize (macroexpand '(let ((a (newline) (newline) (newline))) y)) '())\n"
  "\n"
  "\n"
  ";;; Primitive composition:\n"
  ";; jitterlisp> (ast-optimize (macroexpand '(list 1 2)) '())\n"
  ";; OK[let #<uninterned:0xe6e120> [primitive #<2-ary primitive cons> [literal 2] [literal ()]] [primitive #<2-ary primitive cons> [literal 1] [variable #<uninterned:0xe6e120>]]]\n"
  "\n"
  ";; Make sure that this remains correct:\n"
  ";; OK(ast-optimize (macroexpand '(let ((c 1)) (set! c 4) c)) '())\n"
  ";;   { [let #<u235> [literal 1] [sequence [set! #<u235> [literal 4]] [variable #<u235>]]]\n"
  ";;     CORRECT (difficult to optimize further without a special case). }\n"
  "\n"
  ";; Nice testcases, containing many lets.  Those two should be rewritten\n"
  ";; to different shapes:\n"
  ";; (ast-optimize (macroexpand '(set 1 2 3 4)) ())\n"
  ";; (ast-optimize (macroexpand '(set 1 x 3 4)) ())\n"
  "\n"
  ";; Check that these are correctly optimized:\n"
  ";; OK(ast-optimize (macroexpand '(begin2 x y)) ())\n"
  ";;   {  [sequence [variable x] [variable y]] is CORRECT }\n"
  ";; OK(ast-optimize (macroexpand '(begin1 x y z)) ())\n"
  ";;   {  [sequence [variable y] [sequence [variable z] [variable x]]] is WRONG }\n"
  ";; OK(ast-optimize (macroexpand '(begin2 x y z)) ())\n"
  ";;   {  [sequence [variable x] [sequence [variable z] [variable y]]] is WRONG }\n"
  ";; OK(ast-optimize (macroexpand '(let ((a (f 1)) (b a)) 4)) ())\n"
  ";;   {  [let #<u263> [call [variable f] [literal 1]] [literal 4]] would be\n"
  ";;      wrong: a is non-bound and non-constant, so its reference is effectful\n"
  ";;      and cannot be optimized away.\n"
  ";;      [sequence [call [variable f] [literal 1]] [sequence [variable a] [literal 4]]]\n"
  ";;      is GOOD. }\n"
  ";; GOOD(ast-optimize (macroexpand '(let* ((a (f 1)) (b a)) 4)) ())\n"
  ";;   {  [let #<u267> [call [variable f] [literal 1]] [literal 4]] would be\n"
  ";;      correct but subptimal: the let AST should become a sequence AST.\n"
  ";;      [sequence [call [variable f] [literal 1]] [literal 4]] is GOOD.  }\n"
  ";; OK(ast-optimize (macroexpand '(let* ((a (f 1)) (b a)) b)) ())\n"
  ";;   {  [call [variable f] [literal 1]] }\n"
  "\n"
  ";; It's important to rename nonglobals in the caller when optimizing closures:\n"
  ";; otherwise, when inlining callees within the closure body some references to\n"
  ";; globals might be captured by the closure formals.\n"
  ";; FIXME: do I need to do a preliminary global alpha-convertion pass over all\n"
  ";; closures before inlining for the first time?""  I'm almost sure I don't, as\n"
  ";; I always alpha-convert both the expression I am inlining *into* and the\n"
  ";; callee body I'm copying before inlining.\n"
  "\n"
  ";; FIXME: Make sure that when I remove a let binding a variable to an effectful\n"
  ";; expression I check that the variables occurring free in the expression are\n"
  ";; not assigned in the body *before* the variable use in the body.\n"
  ";; [I don't rewrite such lets now, except in the easy case of wrappers; the\n"
  ";;  current solution is therefore correct, even if not as good as it could be].\n"
  "\n"
  ";; (ALL OK)Primitive optimization:\n"
  ";;   (ast-optimize (macroexpand '(if (not a) b c)) ())\n"
  ";;   (ast-optimize (macroexpand '(+ a 1)) ())\n"
  ";;   (ast-optimize (macroexpand '(- a 1)) ())\n"
  ";;   (ast-optimize (macroexpand '(= a 0)) ())\n"
  ";;   (ast-optimize (macroexpand '(= 0 a)) ())\n"
  "\n"
  "\n"
  "\n"
  ";; OK(ast-optimize (macroexpand '(if (not a) b c)) ())\n"
  ";;     [if [variable a] [variable c] [variable b]]\n"
  ";; OK(ast-optimize (macroexpand '(if (begin 1 2 3 a) b c)) ())\n"
  ";;     [if [variable a] [variable b] [variable c]]\n"
  ";; OK(ast-optimize (macroexpand '(if (begin 1 (f 2) 3 a) b c)) ())\n"
  ";;     [sequence [call [variable f] [literal 2]] [if [variable a] [variable b] [variable c]]]\n"
  "\n"
  "\n"
  ";; This must have no redundant lets...\n"
  ";; (ast-optimize (macroexpand '(if (< n 2) a b) ) ())\n"
  "\n"
  ";; (macroexpand '(letrec ((a a)) a))\n"
  ";;     [let a [literal #<undefined>] [sequence [set! a [variable a]] [variable a]]]\n"
  ";; OK(ast-optimize (macroexpand '(letrec ((a a)) a)) ())\n"
  ";;     [literal #<undefined>]\n"
  ";; Optimizing this may be just academic, but why not: a set! of a non-globally\n"
  ";; bound variable to itself can be eliminated.\n"
  "\n"
  ";; Why does this generate a let?""\n"
  ";; OK-UP-TO-HERE (macroexpand '(cadr q))\n"
  ";;   [call [variable cadr] [variable q]]\n"
  ";; SUBOPTIMAL! (ast-optimize (macroexpand '(cadr q)) ())\n"
  ";;   [let #<u1812> [variable q] [primitive #<1-ary primitive car> [primitive #<1-ary primitive cdr> [variable #<u1812>]]]]\n"
  ";; The problem is in closure-wrapper?"" :\n"
  ";; jitterlisp> car\n"
  ";; #<closure () (#<u701>) [primitive #<1-ary primitive car> [variable #<u701>]]>\n"
  ";; jitterlisp> cadr\n"
  ";; #<closure () (#<u1803>) [primitive #<1-ary primitive car> [primitive #<1-ary primitive cdr> [variable #<u1803>]]]>\n"
  ";; jitterlisp> (closure-wrapper?"" car)\n"
  ";; #t\n"
  ";; jitterlisp> (closure-wrapper?"" cadr)\n"
  ";; #f\n"
  ";; Indeed, cadr is not a wrapper according to my definition, and my inlining\n"
  ";; procedure for wrappers wouldn't work on it.\n"
  "\n"
  ";; OK(ast-optimize (macroexpand '((lambda (x y) (+ x y)) 3 5)) ())\n"
  ";;   {  [literal 8]  }\n"
  ";; OK(ast-optimize (macroexpand '((lambda (x y) (+ x Q)) 3 5)) ())\n"
  ";;   {  [primitive #<2-ary primitive primordial-+> [literal 3] [variable Q]]  }\n"
  ";; OK(ast-optimize (macroexpand '((lambda (x y) (+ x 3)) 10 a)) ())\n"
  ";;   {  [sequence [variable a] [literal 13]]  }\n"
  "\n"
  ";; GOOD-EVEN-IF-IT-LOOKS-WRONG(to (let ((c '(1 2))) (set-car! c 42) c))\n"
  ";;   {  This rewrites to\n"
  ";;         [sequence [primitive #<2-ary primitive set-car!> [literal (1 2)] [literal 42]] [literal ...]]\n"
  ";;      Notice the shared literal, which is of course the same list initially\n"
  ";;      built as (1 2).  The block returns a literal, but the literal is\n"
  ";;      actually a pointer to something which gets destructively changed, so the\n"
  ";;      effect of the assignment is not lost.  As long as returning literals is\n"
  ";;      efficient independently from their type (which has always been assumed\n"
  ";;      up to this point -- even if it will almost certainly change with a\n"
  ";;      moving GC) this is a good, fast solution.  JitterLisp conses are\n"
  ";;      always mutable.\n"
  ";;   }\n"
  "\n"
  ";; FIXME: implement a few more rewritings.\n"
  ";; optimizing this requires an equality predicate for ASTs.  In practice\n"
  ";; it will be fast.\n"
  ";; SUBOPTIMAL(ast-optimize (macroexpand '(lambda (a) (and a #f))) ())\n"
  ";;   { [lambda (#<u1228>) [if [variable #<u1228>] [literal #f] [literal #f]]]\n"
  ";;     This is always correct: [if E1 E2 E2] => [sequence E1 E2] }\n"
  ";; A more subtle, but possibly more useful case to optimize:\n"
  ";; SUBOPTIMAL(ast-optimize (macroexpand '(lambda (a) (and a a))) ())\n"
  ";;   { [lambda (#<u1229>) [if [variable #<u1229>] [variable #<u1229>] [literal #f]]]\n"
  ";;     Here the idea is that [if E E #f] can be rewritten to E when E is\n"
  ";;     non-effectful.  }\n"
  ";; SUBOPTIMAL(ast-optimize (macroexpand '(lambda (a) (lispy-or a a))) ())\n"
  ";;   { [lambda (#<u1234>) [if [variable #<u1234>] [variable #<u1234>] [variable #<u1234>]]]\n"
  ";;     There should be no need for an explicit rewrite\n"
  ";;       [if E E E] => E when E is non-effectful\n"
  ";;     ; this is subsumed by the new rule above and sequence semplification,\n"
  ";;     using [sequence E E] as an intermediate step. }\n"
  ";; After implementing the rule above check:\n"
  ";; SUBOPTIMAL(ast-optimize (macroexpand '(lambda (a) (lispy-or a a a))) ())\n"
  ";;   { [lambda (#<u1250>) [if [variable #<u1250>] [variable #<u1250>] [if [variable #<u1250>] [variable #<u1250>] [variable #<u1250>]]]] }\n"
  "\n"
  "\n"
  ";; (and a b c) => (if a (if b c #f) #f)\n"
  ";; (and a b c) => (not (or (not a) (not b) (not c)))\n"
  "(define-macro (and2 . clauses)\n"
  "  (if (null?"" clauses)\n"
  "      '#t\n"
  "      (let ((res-name (gensym)))\n"
  "        `(let ((,res-name #t))\n"
  "           (cond ,@(map (lambda (clause)\n"
  "                          `((not ,clause)\n"
  "                            (set! ,res-name #f)))\n"
  "                        (all-but-last clauses))\n"
  "                 (else\n"
  "                  (set! ,res-name ,(last clauses))))\n"
  "           ,res-name))))\n"
  "\n"
  ";; (define-constant (length-do xs)\n"
  ";;   (do ((res 0 (1+ res))\n"
  ";;        (xs xs (cdr xs)))\n"
  ";;       ((null?"" xs) res)))\n"
  ";; (declaim ;;(ftype (function (list) fixnum) length-do)\n"
  ";;          (optimize (safety 0) (debug 0) (space 0) (speed 3))\n"
  ";;          (inline + -))\n"
  ";; (defun length-do (xs)\n"
  ";;   (declare (type list xs))\n"
  ";;   (do ((res 0 (1+ res))\n"
  ";;        (xs xs (cdr xs)))\n"
  ";;       ((null xs) res)\n"
  ";;     (declare (type fixnum res))\n"
  ";;     ))\n"
  ";; (defmacro while (guard &rest body-forms)\n"
  ";;   `(do ()\n"
  ";;        ((not ,guard))\n"
  ";;      ,@body-forms))\n"
  ";; (defun length-while (xs)\n"
  ";;   (declare (type list xs))\n"
  ";;   (let ((res 0))\n"
  ";;     (declare (type fixnum res))\n"
  ";;     (while (not (null xs))\n"
  ";;       (setq res (1+ res))\n"
  ";;       (setq xs (cdr xs)))\n"
  ";;     res))\n"
  "\n"
  ";; A good test case for the used-result flag.\n"
  ";; (c (lambda (a b) (when a (set! b a)) b))\n"
  "\n"
  ";; (when #f\n"
  ";;   (define (f x y)\n"
  ";;     (cons x y))\n"
  ";;   f\n"
  ";;   (closure-compile! f)\n"
  ";;   (display (f 10 20))\n"
  ";;   (newline)\n"
  "\n"
  ";;   (define (g x y z)\n"
  ";;     (display y))\n"
  ";;   g\n"
  ";;   (closure-compile! g)\n"
  ";;   (display (g 10 20 30))\n"
  ";;   (newline)\n"
  ";;   )\n"
  "\n"
  ";; Wrong result on PowerPC:\n"
  ";; Q='bin/jitterlisp--unsafe--no-threading'; make -j && make -j $Q && time -p rj ./scripts/emulator $Q --colorize --no-omit-nothing --vm --repl --cross-disassemble --compact-uninterned --no-repl --eval '(disassemble gauss) (gauss 1)' 2>&1 \n"
  ";;\n"
  ";; The saved address on the return stack is wrong: the second one is equal to\n"
  ";; the first.\n"
  "\n"
  ";; Here the opcode is in r31 for debugging.  r20 is the link register.\n"
  ";; r27 is the return stack top pointer.\n"
  ";; This is good:\n"
  ";; # 0x100b9bd4: procedure-prolog (8 bytes):\n"
  ";;     0xf5d80000 92 9b 00 00      stw     r20,0(r27)\n"
  ";;     0xf5d80004 3b e0 00 67      li      r31,103\n"
  ";; ;; This is bad:\n"
  ";; # 0x100b9bec: call/n1/retR 0xf5d80690 (136 bytes):\n"
  ";;     ...\n"
  ";;     # Beginning of the compiled-closure part.\n"
  ";;     0xf5d80624 3b 7b 00 04      addi    r27,r27,4\n"
  ";;     0xf5d80628 81 48 00 14      lwz     r10,20(r8)\n"
  ";;     0xf5d8062c 7d 49 03 a6      mtctr   r10\n"
  ";;     0xf5d80630 4e 80 04 20      bctr\n"
  ";;     0xf5d80634 3b e0 00 0b      li      r31,11\n"
  ";;     0xf5d80638 7e 14 83 78      mr      r20,r16\n"
  ";;     # End of the compiled-closure part.\n"
  ";;     ...\n"
  ";; The link register is set *after* the call which is supposed to save\n"
  ";; it to the return stack.\n"
  "\n"
  ";; (disassemble-vm (let* ((a 1)) (lambda (x) (+ x a))))\n"
  ";; (disassemble-vm (lambda (x) y))\n"
  "\n"
  ";; Similar on x86_64, GCC 7 only:\n"
  ";; # 0x55578e8: call-from-c/retR 0xffffffffffffffff (93 bytes):\n"
  ";;     0x000000000402a000 48 8b 74 24 18       	movq   0x18(%rsp),%rsi\n"
  ";;     0x000000000402a005 48 8b 54 24 10       	movq   0x10(%rsp),%rdx\n"
  ";;     0x000000000402a00a 48 8b 06             	movq   (%rsi),%rax\n"
  ";;     0x000000000402a00d 48 83 ee 08          	subq   $0x8,%rsi\n"
  ";;     0x000000000402a011 48 89 74 24 18       	movq   %rsi,0x18(%rsp)\n"
  ";;     0x000000000402a016 48 89 c1             	movq   %rax,%rcx\n"
  ";;     0x000000000402a019 48 85 d2             	testq  %rdx,%rdx\n"
  ";;     0x000000000402a01c 74 09                	je     0x000000000402a027\n"
  ";;     0x000000000402a01e 48 6b d2 f8          	imulq  $0xfffffffffffffff8,%rdx,%rdx\n"
  ";;     0x000000000402a022 48 8b 4c 16 08       	movq   0x8(%rsi,%rdx,1),%rcx\n"
  ";;     0x000000000402a027 0f 1f 04 25 aa 00 00 00 	nopl   0xaa\n"
  ";;     0x000000000402a02f 48 8b 74 24 20       	movq   0x20(%rsp),%rsi\n"
  ";;     0x000000000402a034 48 8d 56 08          	leaq   0x8(%rsi),%rdx\n"
  ";;     0x000000000402a038 0f 1f 04 25 bb 00 00 00 	nopl   0xbb\n"
  ";;     0x000000000402a040 48 c7 46 08 aa aa 42 42 	movq   $0x4242aaaa,0x8(%rsi)\n"
  ";;     0x000000000402a048 0f 1f 04 25 cc 00 00 00 	nopl   0xcc\n"
  ";;     0x000000000402a050 ff 51 25             	callq  *0x25(%rcx)\n"
  ";;     0x000000000402a053 48 89 54 24 20       	movq   %rdx,0x20(%rsp)\n"
  ";;     0x000000000402a058 48 89 44 24 10       	movq   %rax,0x10(%rsp)\n"
  ";; The two nopl instructions are for debugging.  The two movq are run too late,\n"
  ";; after the call: 0x20(%rsp) is the return stack pointer, in this case held\n"
  ";; in memory.  The instruction run after the call would have stored the correct\n"
  ";; value if run before.\n"
  ";;\n"
  ";; Should JITTER_BRANCH_AND_LINK and JITTER_BRANCH_FAST_AND_LINK end with\n"
  ";; __builtin_unreachable to prevent this kind of behavior?""  I guess not:\n"
  ";; sometimes I really want a jump instruction to be generated after the\n"
  ";; branch-and-link instruction, to skip the rest of the VM instruction code\n"
  ";; which is not empty.\n"
  ";; Should JITTER_BRANCH_AND_LINK and JITTER_BRANCH_FAST_AND_LINK clobber\n"
  ";; memory?""  Would that help?"" [Tested: no it wouldn't]\n"
  ";;\n"
  ";; I have understood the problem now.\n"
  ";; -fno-sched-interblock might work as a last-ditch workaround, but I should\n"
  ";; do something more solid. [No, it wouldn't]\n"
  "\n"
  ";; The GCC parameter max-goto-duplication-insns was defined following Anton\n"
  ";; Ertl's complaint about unconditional branches to branches, which bothers\n"
  ";; me as well, in https://gcc.gnu.org/bugzilla/show_bug.cgi?""id=15242 .\n"
  ";; It is supposed to be a solution.\n"
  ";; https://gcc.gnu.org/bugzilla/show_bug.cgi?""id=15242 reported by Bernd Paysan\n"
  ";; is about similar issues, again also concerning me.\n"
  "\n"
  ";; This fails: why?""\n"
  ";; (c ast-equal?"")\n"
  "\n"
  ";; MIPS: the 18 test suite failures are prevented by undefining\n"
  ";; JITTER_MACHINE_SUPPORTS_PROCEDURE.  I have to understand why.\n"
  "\n"
  "(when #f\n"
  "  (define-constant (ap f x) (f x))\n"
  "  (define (w) (ap 1+ 10))\n"
  "  (disassemble-vm w)\n"
  "  (disassemble-vm ap)\n"
  "  )\n"
  "\n"
  ";; As of 2018-03-02, after changing runtime definitions and code generation but before\n"
  ";; cleaning them up, I'm seeing failures only on minimal-threading.  I think the problem\n"
  ";; is in the call VM instruction: I don't see the link register in 0x10(%rsp) ever being\n"
  ";; set.\n"
  "(define-constant (CONS car cdr)\n"
  "  (lambda (selector) (selector car cdr)))\n"
  "(define-constant (CAR-SELECTOR car cdr)\n"
  "  car)\n"
  "(define-constant (CDR-SELECTOR car cdr)\n"
  "  cdr)\n"
  "(define-constant (CAR cons)\n"
  "  (cons CAR-SELECTOR))\n"
  "(define-constant (CDR cons)\n"
  "  (cons CDR-SELECTOR))\n"
  "(define-macro (LIST . args)\n"
  "  (if (null?"" args)\n"
  "      '()\n"
  "      `(CONS ,(car args) (LIST ,@(cdr args)))))\n"
;
const char *jitterlisp_no_warranty =
  "Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>\n"
  "Everyone is permitted to copy and distribute verbatim copies\n"
  "of this license document, but changing it is not allowed.\n"
  "\n"
  "[This is an excerpt of the GNU General Public License; you can find the\n"
  " full text of the license in the file COPYING]\n"
  "\n"
  "NO WARRANTY\n"
  "-----------\n"
  "\n"
  "  15. Disclaimer of Warranty.\n"
  "\n"
  "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY\n"
  "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT\n"
  "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY\n"
  "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,\n"
  "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR\n"
  "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM\n"
  "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF\n"
  "ALL NECESSARY SERVICING, REPAIR OR CORRECTION.\n"
  "\n"
  "  16. Limitation of Liability.\n"
  "\n"
  "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\n"
  "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS\n"
  "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY\n"
  "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE\n"
  "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF\n"
  "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD\n"
  "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),\n"
  "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF\n"
  "SUCH DAMAGES.\n"
  "\n"
  "  17. Interpretation of Sections 15 and 16.\n"
  "\n"
  "  If the disclaimer of warranty and limitation of liability provided\n"
  "above cannot be given local legal effect according to their terms,\n"
  "reviewing courts shall apply local law that most closely approximates\n"
  "an absolute waiver of all civil liability in connection with the\n"
  "Program, unless a warranty or assumption of liability accompanies a\n"
  "copy of the Program in return for a fee.\n"
;
const char *jitterlisp_gpl =
  "                    GNU GENERAL PUBLIC LICENSE\n"
  "                       Version 3, 29 June 2007\n"
  "\n"
  " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>\n"
  " Everyone is permitted to copy and distribute verbatim copies\n"
  " of this license document, but changing it is not allowed.\n"
  "\n"
  "                            Preamble\n"
  "\n"
  "  The GNU General Public License is a free, copyleft license for\n"
  "software and other kinds of works.\n"
  "\n"
  "  The licenses for most software and other practical works are designed\n"
  "to take away your freedom to share and change the works.  By contrast,\n"
  "the GNU General Public License is intended to guarantee your freedom to\n"
  "share and change all versions of a program--to make sure it remains free\n"
  "software for all its users.  We, the Free Software Foundation, use the\n"
  "GNU General Public License for most of our software; it applies also to\n"
  "any other work released this way by its authors.  You can apply it to\n"
  "your programs, too.\n"
  "\n"
  "  When we speak of free software, we are referring to freedom, not\n"
  "price.  Our General Public Licenses are designed to make sure that you\n"
  "have the freedom to distribute copies of free software (and charge for\n"
  "them if you wish), that you receive source code or can get it if you\n"
  "want it, that you can change the software or use pieces of it in new\n"
  "free programs, and that you know you can do these things.\n"
  "\n"
  "  To protect your rights, we need to prevent others from denying you\n"
  "these rights or asking you to surrender the rights.  Therefore, you have\n"
  "certain responsibilities if you distribute copies of the software, or if\n"
  "you modify it: responsibilities to respect the freedom of others.\n"
  "\n"
  "  For example, if you distribute copies of such a program, whether\n"
  "gratis or for a fee, you must pass on to the recipients the same\n"
  "freedoms that you received.  You must make sure that they, too, receive\n"
  "or can get the source code.  And you must show them these terms so they\n"
  "know their rights.\n"
  "\n"
  "  Developers that use the GNU GPL protect your rights with two steps:\n"
  "(1) assert copyright on the software, and (2) offer you this License\n"
  "giving you legal permission to copy, distribute and/or modify it.\n"
  "\n"
  "  For the developers' and authors' protection, the GPL clearly explains\n"
  "that there is no warranty for this free software.  For both users' and\n"
  "authors' sake, the GPL requires that modified versions be marked as\n"
  "changed, so that their problems will not be attributed erroneously to\n"
  "authors of previous versions.\n"
  "\n"
  "  Some devices are designed to deny users access to install or run\n"
  "modified versions of the software inside them, although the manufacturer\n"
  "can do so.  This is fundamentally incompatible with the aim of\n"
  "protecting users' freedom to change the software.  The systematic\n"
  "pattern of such abuse occurs in the area of products for individuals to\n"
  "use, which is precisely where it is most unacceptable.  Therefore, we\n"
  "have designed this version of the GPL to prohibit the practice for those\n"
  "products.  If such problems arise substantially in other domains, we\n"
  "stand ready to extend this provision to those domains in future versions\n"
  "of the GPL, as needed to protect the freedom of users.\n"
  "\n"
  "  Finally, every program is threatened constantly by software patents.\n"
  "States should not allow patents to restrict development and use of\n"
  "software on general-purpose computers, but in those that do, we wish to\n"
  "avoid the special danger that patents applied to a free program could\n"
  "make it effectively proprietary.  To prevent this, the GPL assures that\n"
  "patents cannot be used to render the program non-free.\n"
  "\n"
  "  The precise terms and conditions for copying, distribution and\n"
  "modification follow.\n"
  "\n"
  "                       TERMS AND CONDITIONS\n"
  "\n"
  "  0. Definitions.\n"
  "\n"
  "  \"This License\" refers to version 3 of the GNU General Public License.\n"
  "\n"
  "  \"Copyright\" also means copyright-like laws that apply to other kinds of\n"
  "works, such as semiconductor masks.\n"
  "\n"
  "  \"The Program\" refers to any copyrightable work licensed under this\n"
  "License.  Each licensee is addressed as \"you\".  \"Licensees\" and\n"
  "\"recipients\" may be individuals or organizations.\n"
  "\n"
  "  To \"modify\" a work means to copy from or adapt all or part of the work\n"
  "in a fashion requiring copyright permission, other than the making of an\n"
  "exact copy.  The resulting work is called a \"modified version\" of the\n"
  "earlier work or a work \"based on\" the earlier work.\n"
  "\n"
  "  A \"covered work\" means either the unmodified Program or a work based\n"
  "on the Program.\n"
  "\n"
  "  To \"propagate\" a work means to do anything with it that, without\n"
  "permission, would make you directly or secondarily liable for\n"
  "infringement under applicable copyright law, except executing it on a\n"
  "computer or modifying a private copy.  Propagation includes copying,\n"
  "distribution (with or without modification), making available to the\n"
  "public, and in some countries other activities as well.\n"
  "\n"
  "  To \"convey\" a work means any kind of propagation that enables other\n"
  "parties to make or receive copies.  Mere interaction with a user through\n"
  "a computer network, with no transfer of a copy, is not conveying.\n"
  "\n"
  "  An interactive user interface displays \"Appropriate Legal Notices\"\n"
  "to the extent that it includes a convenient and prominently visible\n"
  "feature that (1) displays an appropriate copyright notice, and (2)\n"
  "tells the user that there is no warranty for the work (except to the\n"
  "extent that warranties are provided), that licensees may convey the\n"
  "work under this License, and how to view a copy of this License.  If\n"
  "the interface presents a list of user commands or options, such as a\n"
  "menu, a prominent item in the list meets this criterion.\n"
  "\n"
  "  1. Source Code.\n"
  "\n"
  "  The \"source code\" for a work means the preferred form of the work\n"
  "for making modifications to it.  \"Object code\" means any non-source\n"
  "form of a work.\n"
  "\n"
  "  A \"Standard Interface\" means an interface that either is an official\n"
  "standard defined by a recognized standards body, or, in the case of\n"
  "interfaces specified for a particular programming language, one that\n"
  "is widely used among developers working in that language.\n"
  "\n"
  "  The \"System Libraries\" of an executable work include anything, other\n"
  "than the work as a whole, that (a) is included in the normal form of\n"
  "packaging a Major Component, but which is not part of that Major\n"
  "Component, and (b) serves only to enable use of the work with that\n"
  "Major Component, or to implement a Standard Interface for which an\n"
  "implementation is available to the public in source code form.  A\n"
  "\"Major Component\", in this context, means a major essential component\n"
  "(kernel, window system, and so on) of the specific operating system\n"
  "(if any) on which the executable work runs, or a compiler used to\n"
  "produce the work, or an object code interpreter used to run it.\n"
  "\n"
  "  The \"Corresponding Source\" for a work in object code form means all\n"
  "the source code needed to generate, install, and (for an executable\n"
  "work) run the object code and to modify the work, including scripts to\n"
  "control those activities.  However, it does not include the work's\n"
  "System Libraries, or general-purpose tools or generally available free\n"
  "programs which are used unmodified in performing those activities but\n"
  "which are not part of the work.  For example, Corresponding Source\n"
  "includes interface definition files associated with source files for\n"
  "the work, and the source code for shared libraries and dynamically\n"
  "linked subprograms that the work is specifically designed to require,\n"
  "such as by intimate data communication or control flow between those\n"
  "subprograms and other parts of the work.\n"
  "\n"
  "  The Corresponding Source need not include anything that users\n"
  "can regenerate automatically from other parts of the Corresponding\n"
  "Source.\n"
  "\n"
  "  The Corresponding Source for a work in source code form is that\n"
  "same work.\n"
  "\n"
  "  2. Basic Permissions.\n"
  "\n"
  "  All rights granted under this License are granted for the term of\n"
  "copyright on the Program, and are irrevocable provided the stated\n"
  "conditions are met.  This License explicitly affirms your unlimited\n"
  "permission to run the unmodified Program.  The output from running a\n"
  "covered work is covered by this License only if the output, given its\n"
  "content, constitutes a covered work.  This License acknowledges your\n"
  "rights of fair use or other equivalent, as provided by copyright law.\n"
  "\n"
  "  You may make, run and propagate covered works that you do not\n"
  "convey, without conditions so long as your license otherwise remains\n"
  "in force.  You may convey covered works to others for the sole purpose\n"
  "of having them make modifications exclusively for you, or provide you\n"
  "with facilities for running those works, provided that you comply with\n"
  "the terms of this License in conveying all material for which you do\n"
  "not control copyright.  Those thus making or running the covered works\n"
  "for you must do so exclusively on your behalf, under your direction\n"
  "and control, on terms that prohibit them from making any copies of\n"
  "your copyrighted material outside their relationship with you.\n"
  "\n"
  "  Conveying under any other circumstances is permitted solely under\n"
  "the conditions stated below.  Sublicensing is not allowed; section 10\n"
  "makes it unnecessary.\n"
  "\n"
  "  3. Protecting Users' Legal Rights From Anti-Circumvention Law.\n"
  "\n"
  "  No covered work shall be deemed part of an effective technological\n"
  "measure under any applicable law fulfilling obligations under article\n"
  "11 of the WIPO copyright treaty adopted on 20 December 1996, or\n"
  "similar laws prohibiting or restricting circumvention of such\n"
  "measures.\n"
  "\n"
  "  When you convey a covered work, you waive any legal power to forbid\n"
  "circumvention of technological measures to the extent such circumvention\n"
  "is effected by exercising rights under this License with respect to\n"
  "the covered work, and you disclaim any intention to limit operation or\n"
  "modification of the work as a means of enforcing, against the work's\n"
  "users, your or third parties' legal rights to forbid circumvention of\n"
  "technological measures.\n"
  "\n"
  "  4. Conveying Verbatim Copies.\n"
  "\n"
  "  You may convey verbatim copies of the Program's source code as you\n"
  "receive it, in any medium, provided that you conspicuously and\n"
  "appropriately publish on each copy an appropriate copyright notice;\n"
  "keep intact all notices stating that this License and any\n"
  "non-permissive terms added in accord with section 7 apply to the code;\n"
  "keep intact all notices of the absence of any warranty; and give all\n"
  "recipients a copy of this License along with the Program.\n"
  "\n"
  "  You may charge any price or no price for each copy that you convey,\n"
  "and you may offer support or warranty protection for a fee.\n"
  "\n"
  "  5. Conveying Modified Source Versions.\n"
  "\n"
  "  You may convey a work based on the Program, or the modifications to\n"
  "produce it from the Program, in the form of source code under the\n"
  "terms of section 4, provided that you also meet all of these conditions:\n"
  "\n"
  "    a) The work must carry prominent notices stating that you modified\n"
  "    it, and giving a relevant date.\n"
  "\n"
  "    b) The work must carry prominent notices stating that it is\n"
  "    released under this License and any conditions added under section\n"
  "    7.  This requirement modifies the requirement in section 4 to\n"
  "    \"keep intact all notices\".\n"
  "\n"
  "    c) You must license the entire work, as a whole, under this\n"
  "    License to anyone who comes into possession of a copy.  This\n"
  "    License will therefore apply, along with any applicable section 7\n"
  "    additional terms, to the whole of the work, and all its parts,\n"
  "    regardless of how they are packaged.  This License gives no\n"
  "    permission to license the work in any other way, but it does not\n"
  "    invalidate such permission if you have separately received it.\n"
  "\n"
  "    d) If the work has interactive user interfaces, each must display\n"
  "    Appropriate Legal Notices; however, if the Program has interactive\n"
  "    interfaces that do not display Appropriate Legal Notices, your\n"
  "    work need not make them do so.\n"
  "\n"
  "  A compilation of a covered work with other separate and independent\n"
  "works, which are not by their nature extensions of the covered work,\n"
  "and which are not combined with it such as to form a larger program,\n"
  "in or on a volume of a storage or distribution medium, is called an\n"
  "\"aggregate\" if the compilation and its resulting copyright are not\n"
  "used to limit the access or legal rights of the compilation's users\n"
  "beyond what the individual works permit.  Inclusion of a covered work\n"
  "in an aggregate does not cause this License to apply to the other\n"
  "parts of the aggregate.\n"
  "\n"
  "  6. Conveying Non-Source Forms.\n"
  "\n"
  "  You may convey a covered work in object code form under the terms\n"
  "of sections 4 and 5, provided that you also convey the\n"
  "machine-readable Corresponding Source under the terms of this License,\n"
  "in one of these ways:\n"
  "\n"
  "    a) Convey the object code in, or embodied in, a physical product\n"
  "    (including a physical distribution medium), accompanied by the\n"
  "    Corresponding Source fixed on a durable physical medium\n"
  "    customarily used for software interchange.\n"
  "\n"
  "    b) Convey the object code in, or embodied in, a physical product\n"
  "    (including a physical distribution medium), accompanied by a\n"
  "    written offer, valid for at least three years and valid for as\n"
  "    long as you offer spare parts or customer support for that product\n"
  "    model, to give anyone who possesses the object code either (1) a\n"
  "    copy of the Corresponding Source for all the software in the\n"
  "    product that is covered by this License, on a durable physical\n"
  "    medium customarily used for software interchange, for a price no\n"
  "    more than your reasonable cost of physically performing this\n"
  "    conveying of source, or (2) access to copy the\n"
  "    Corresponding Source from a network server at no charge.\n"
  "\n"
  "    c) Convey individual copies of the object code with a copy of the\n"
  "    written offer to provide the Corresponding Source.  This\n"
  "    alternative is allowed only occasionally and noncommercially, and\n"
  "    only if you received the object code with such an offer, in accord\n"
  "    with subsection 6b.\n"
  "\n"
  "    d) Convey the object code by offering access from a designated\n"
  "    place (gratis or for a charge), and offer equivalent access to the\n"
  "    Corresponding Source in the same way through the same place at no\n"
  "    further charge.  You need not require recipients to copy the\n"
  "    Corresponding Source along with the object code.  If the place to\n"
  "    copy the object code is a network server, the Corresponding Source\n"
  "    may be on a different server (operated by you or a third party)\n"
  "    that supports equivalent copying facilities, provided you maintain\n"
  "    clear directions next to the object code saying where to find the\n"
  "    Corresponding Source.  Regardless of what server hosts the\n"
  "    Corresponding Source, you remain obligated to ensure that it is\n"
  "    available for as long as needed to satisfy these requirements.\n"
  "\n"
  "    e) Convey the object code using peer-to-peer transmission, provided\n"
  "    you inform other peers where the object code and Corresponding\n"
  "    Source of the work are being offered to the general public at no\n"
  "    charge under subsection 6d.\n"
  "\n"
  "  A separable portion of the object code, whose source code is excluded\n"
  "from the Corresponding Source as a System Library, need not be\n"
  "included in conveying the object code work.\n"
  "\n"
  "  A \"User Product\" is either (1) a \"consumer product\", which means any\n"
  "tangible personal property which is normally used for personal, family,\n"
  "or household purposes, or (2) anything designed or sold for incorporation\n"
  "into a dwelling.  In determining whether a product is a consumer product,\n"
  "doubtful cases shall be resolved in favor of coverage.  For a particular\n"
  "product received by a particular user, \"normally used\" refers to a\n"
  "typical or common use of that class of product, regardless of the status\n"
  "of the particular user or of the way in which the particular user\n"
  "actually uses, or expects or is expected to use, the product.  A product\n"
  "is a consumer product regardless of whether the product has substantial\n"
  "commercial, industrial or non-consumer uses, unless such uses represent\n"
  "the only significant mode of use of the product.\n"
  "\n"
  "  \"Installation Information\" for a User Product means any methods,\n"
  "procedures, authorization keys, or other information required to install\n"
  "and execute modified versions of a covered work in that User Product from\n"
  "a modified version of its Corresponding Source.  The information must\n"
  "suffice to ensure that the continued functioning of the modified object\n"
  "code is in no case prevented or interfered with solely because\n"
  "modification has been made.\n"
  "\n"
  "  If you convey an object code work under this section in, or with, or\n"
  "specifically for use in, a User Product, and the conveying occurs as\n"
  "part of a transaction in which the right of possession and use of the\n"
  "User Product is transferred to the recipient in perpetuity or for a\n"
  "fixed term (regardless of how the transaction is characterized), the\n"
  "Corresponding Source conveyed under this section must be accompanied\n"
  "by the Installation Information.  But this requirement does not apply\n"
  "if neither you nor any third party retains the ability to install\n"
  "modified object code on the User Product (for example, the work has\n"
  "been installed in ROM).\n"
  "\n"
  "  The requirement to provide Installation Information does not include a\n"
  "requirement to continue to provide support service, warranty, or updates\n"
  "for a work that has been modified or installed by the recipient, or for\n"
  "the User Product in which it has been modified or installed.  Access to a\n"
  "network may be denied when the modification itself materially and\n"
  "adversely affects the operation of the network or violates the rules and\n"
  "protocols for communication across the network.\n"
  "\n"
  "  Corresponding Source conveyed, and Installation Information provided,\n"
  "in accord with this section must be in a format that is publicly\n"
  "documented (and with an implementation available to the public in\n"
  "source code form), and must require no special password or key for\n"
  "unpacking, reading or copying.\n"
  "\n"
  "  7. Additional Terms.\n"
  "\n"
  "  \"Additional permissions\" are terms that supplement the terms of this\n"
  "License by making exceptions from one or more of its conditions.\n"
  "Additional permissions that are applicable to the entire Program shall\n"
  "be treated as though they were included in this License, to the extent\n"
  "that they are valid under applicable law.  If additional permissions\n"
  "apply only to part of the Program, that part may be used separately\n"
  "under those permissions, but the entire Program remains governed by\n"
  "this License without regard to the additional permissions.\n"
  "\n"
  "  When you convey a copy of a covered work, you may at your option\n"
  "remove any additional permissions from that copy, or from any part of\n"
  "it.  (Additional permissions may be written to require their own\n"
  "removal in certain cases when you modify the work.)  You may place\n"
  "additional permissions on material, added by you to a covered work,\n"
  "for which you have or can give appropriate copyright permission.\n"
  "\n"
  "  Notwithstanding any other provision of this License, for material you\n"
  "add to a covered work, you may (if authorized by the copyright holders of\n"
  "that material) supplement the terms of this License with terms:\n"
  "\n"
  "    a) Disclaiming warranty or limiting liability differently from the\n"
  "    terms of sections 15 and 16 of this License; or\n"
  "\n"
  "    b) Requiring preservation of specified reasonable legal notices or\n"
  "    author attributions in that material or in the Appropriate Legal\n"
  "    Notices displayed by works containing it; or\n"
  "\n"
  "    c) Prohibiting misrepresentation of the origin of that material, or\n"
  "    requiring that modified versions of such material be marked in\n"
  "    reasonable ways as different from the original version; or\n"
  "\n"
  "    d) Limiting the use for publicity purposes of names of licensors or\n"
  "    authors of the material; or\n"
  "\n"
  "    e) Declining to grant rights under trademark law for use of some\n"
  "    trade names, trademarks, or service marks; or\n"
  "\n"
  "    f) Requiring indemnification of licensors and authors of that\n"
  "    material by anyone who conveys the material (or modified versions of\n"
  "    it) with contractual assumptions of liability to the recipient, for\n"
  "    any liability that these contractual assumptions directly impose on\n"
  "    those licensors and authors.\n"
  "\n"
  "  All other non-permissive additional terms are considered \"further\n"
  "restrictions\" within the meaning of section 10.  If the Program as you\n"
  "received it, or any part of it, contains a notice stating that it is\n"
  "governed by this License along with a term that is a further\n"
  "restriction, you may remove that term.  If a license document contains\n"
  "a further restriction but permits relicensing or conveying under this\n"
  "License, you may add to a covered work material governed by the terms\n"
  "of that license document, provided that the further restriction does\n"
  "not survive such relicensing or conveying.\n"
  "\n"
  "  If you add terms to a covered work in accord with this section, you\n"
  "must place, in the relevant source files, a statement of the\n"
  "additional terms that apply to those files, or a notice indicating\n"
  "where to find the applicable terms.\n"
  "\n"
  "  Additional terms, permissive or non-permissive, may be stated in the\n"
  "form of a separately written license, or stated as exceptions;\n"
  "the above requirements apply either way.\n"
  "\n"
  "  8. Termination.\n"
  "\n"
  "  You may not propagate or modify a covered work except as expressly\n"
  "provided under this License.  Any attempt otherwise to propagate or\n"
  "modify it is void, and will automatically terminate your rights under\n"
  "this License (including any patent licenses granted under the third\n"
  "paragraph of section 11).\n"
  "\n"
  "  However, if you cease all violation of this License, then your\n"
  "license from a particular copyright holder is reinstated (a)\n"
  "provisionally, unless and until the copyright holder explicitly and\n"
  "finally terminates your license, and (b) permanently, if the copyright\n"
  "holder fails to notify you of the violation by some reasonable means\n"
  "prior to 60 days after the cessation.\n"
  "\n"
  "  Moreover, your license from a particular copyright holder is\n"
  "reinstated permanently if the copyright holder notifies you of the\n"
  "violation by some reasonable means, this is the first time you have\n"
  "received notice of violation of this License (for any work) from that\n"
  "copyright holder, and you cure the violation prior to 30 days after\n"
  "your receipt of the notice.\n"
  "\n"
  "  Termination of your rights under this section does not terminate the\n"
  "licenses of parties who have received copies or rights from you under\n"
  "this License.  If your rights have been terminated and not permanently\n"
  "reinstated, you do not qualify to receive new licenses for the same\n"
  "material under section 10.\n"
  "\n"
  "  9. Acceptance Not Required for Having Copies.\n"
  "\n"
  "  You are not required to accept this License in order to receive or\n"
  "run a copy of the Program.  Ancillary propagation of a covered work\n"
  "occurring solely as a consequence of using peer-to-peer transmission\n"
  "to receive a copy likewise does not require acceptance.  However,\n"
  "nothing other than this License grants you permission to propagate or\n"
  "modify any covered work.  These actions infringe copyright if you do\n"
  "not accept this License.  Therefore, by modifying or propagating a\n"
  "covered work, you indicate your acceptance of this License to do so.\n"
  "\n"
  "  10. Automatic Licensing of Downstream Recipients.\n"
  "\n"
  "  Each time you convey a covered work, the recipient automatically\n"
  "receives a license from the original licensors, to run, modify and\n"
  "propagate that work, subject to this License.  You are not responsible\n"
  "for enforcing compliance by third parties with this License.\n"
  "\n"
  "  An \"entity transaction\" is a transaction transferring control of an\n"
  "organization, or substantially all assets of one, or subdividing an\n"
  "organization, or merging organizations.  If propagation of a covered\n"
  "work results from an entity transaction, each party to that\n"
  "transaction who receives a copy of the work also receives whatever\n"
  "licenses to the work the party's predecessor in interest had or could\n"
  "give under the previous paragraph, plus a right to possession of the\n"
  "Corresponding Source of the work from the predecessor in interest, if\n"
  "the predecessor has it or can get it with reasonable efforts.\n"
  "\n"
  "  You may not impose any further restrictions on the exercise of the\n"
  "rights granted or affirmed under this License.  For example, you may\n"
  "not impose a license fee, royalty, or other charge for exercise of\n"
  "rights granted under this License, and you may not initiate litigation\n"
  "(including a cross-claim or counterclaim in a lawsuit) alleging that\n"
  "any patent claim is infringed by making, using, selling, offering for\n"
  "sale, or importing the Program or any portion of it.\n"
  "\n"
  "  11. Patents.\n"
  "\n"
  "  A \"contributor\" is a copyright holder who authorizes use under this\n"
  "License of the Program or a work on which the Program is based.  The\n"
  "work thus licensed is called the contributor's \"contributor version\".\n"
  "\n"
  "  A contributor's \"essential patent claims\" are all patent claims\n"
  "owned or controlled by the contributor, whether already acquired or\n"
  "hereafter acquired, that would be infringed by some manner, permitted\n"
  "by this License, of making, using, or selling its contributor version,\n"
  "but do not include claims that would be infringed only as a\n"
  "consequence of further modification of the contributor version.  For\n"
  "purposes of this definition, \"control\" includes the right to grant\n"
  "patent sublicenses in a manner consistent with the requirements of\n"
  "this License.\n"
  "\n"
  "  Each contributor grants you a non-exclusive, worldwide, royalty-free\n"
  "patent license under the contributor's essential patent claims, to\n"
  "make, use, sell, offer for sale, import and otherwise run, modify and\n"
  "propagate the contents of its contributor version.\n"
  "\n"
  "  In the following three paragraphs, a \"patent license\" is any express\n"
  "agreement or commitment, however denominated, not to enforce a patent\n"
  "(such as an express permission to practice a patent or covenant not to\n"
  "sue for patent infringement).  To \"grant\" such a patent license to a\n"
  "party means to make such an agreement or commitment not to enforce a\n"
  "patent against the party.\n"
  "\n"
  "  If you convey a covered work, knowingly relying on a patent license,\n"
  "and the Corresponding Source of the work is not available for anyone\n"
  "to copy, free of charge and under the terms of this License, through a\n"
  "publicly available network server or other readily accessible means,\n"
  "then you must either (1) cause the Corresponding Source to be so\n"
  "available, or (2) arrange to deprive yourself of the benefit of the\n"
  "patent license for this particular work, or (3) arrange, in a manner\n"
  "consistent with the requirements of this License, to extend the patent\n"
  "license to downstream recipients.  \"Knowingly relying\" means you have\n"
  "actual knowledge that, but for the patent license, your conveying the\n"
  "covered work in a country, or your recipient's use of the covered work\n"
  "in a country, would infringe one or more identifiable patents in that\n"
  "country that you have reason to believe are valid.\n"
  "\n"
  "  If, pursuant to or in connection with a single transaction or\n"
  "arrangement, you convey, or propagate by procuring conveyance of, a\n"
  "covered work, and grant a patent license to some of the parties\n"
  "receiving the covered work authorizing them to use, propagate, modify\n"
  "or convey a specific copy of the covered work, then the patent license\n"
  "you grant is automatically extended to all recipients of the covered\n"
  "work and works based on it.\n"
  "\n"
  "  A patent license is \"discriminatory\" if it does not include within\n"
  "the scope of its coverage, prohibits the exercise of, or is\n"
  "conditioned on the non-exercise of one or more of the rights that are\n"
  "specifically granted under this License.  You may not convey a covered\n"
  "work if you are a party to an arrangement with a third party that is\n"
  "in the business of distributing software, under which you make payment\n"
  "to the third party based on the extent of your activity of conveying\n"
  "the work, and under which the third party grants, to any of the\n"
  "parties who would receive the covered work from you, a discriminatory\n"
  "patent license (a) in connection with copies of the covered work\n"
  "conveyed by you (or copies made from those copies), or (b) primarily\n"
  "for and in connection with specific products or compilations that\n"
  "contain the covered work, unless you entered into that arrangement,\n"
  "or that patent license was granted, prior to 28 March 2007.\n"
  "\n"
  "  Nothing in this License shall be construed as excluding or limiting\n"
  "any implied license or other defenses to infringement that may\n"
  "otherwise be available to you under applicable patent law.\n"
  "\n"
  "  12. No Surrender of Others' Freedom.\n"
  "\n"
  "  If conditions are imposed on you (whether by court order, agreement or\n"
  "otherwise) that contradict the conditions of this License, they do not\n"
  "excuse you from the conditions of this License.  If you cannot convey a\n"
  "covered work so as to satisfy simultaneously your obligations under this\n"
  "License and any other pertinent obligations, then as a consequence you may\n"
  "not convey it at all.  For example, if you agree to terms that obligate you\n"
  "to collect a royalty for further conveying from those to whom you convey\n"
  "the Program, the only way you could satisfy both those terms and this\n"
  "License would be to refrain entirely from conveying the Program.\n"
  "\n"
  "  13. Use with the GNU Affero General Public License.\n"
  "\n"
  "  Notwithstanding any other provision of this License, you have\n"
  "permission to link or combine any covered work with a work licensed\n"
  "under version 3 of the GNU Affero General Public License into a single\n"
  "combined work, and to convey the resulting work.  The terms of this\n"
  "License will continue to apply to the part which is the covered work,\n"
  "but the special requirements of the GNU Affero General Public License,\n"
  "section 13, concerning interaction through a network will apply to the\n"
  "combination as such.\n"
  "\n"
  "  14. Revised Versions of this License.\n"
  "\n"
  "  The Free Software Foundation may publish revised and/or new versions of\n"
  "the GNU General Public License from time to time.  Such new versions will\n"
  "be similar in spirit to the present version, but may differ in detail to\n"
  "address new problems or concerns.\n"
  "\n"
  "  Each version is given a distinguishing version number.  If the\n"
  "Program specifies that a certain numbered version of the GNU General\n"
  "Public License \"or any later version\" applies to it, you have the\n"
  "option of following the terms and conditions either of that numbered\n"
  "version or of any later version published by the Free Software\n"
  "Foundation.  If the Program does not specify a version number of the\n"
  "GNU General Public License, you may choose any version ever published\n"
  "by the Free Software Foundation.\n"
  "\n"
  "  If the Program specifies that a proxy can decide which future\n"
  "versions of the GNU General Public License can be used, that proxy's\n"
  "public statement of acceptance of a version permanently authorizes you\n"
  "to choose that version for the Program.\n"
  "\n"
  "  Later license versions may give you additional or different\n"
  "permissions.  However, no additional obligations are imposed on any\n"
  "author or copyright holder as a result of your choosing to follow a\n"
  "later version.\n"
  "\n"
  "  15. Disclaimer of Warranty.\n"
  "\n"
  "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY\n"
  "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT\n"
  "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY\n"
  "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,\n"
  "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR\n"
  "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM\n"
  "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF\n"
  "ALL NECESSARY SERVICING, REPAIR OR CORRECTION.\n"
  "\n"
  "  16. Limitation of Liability.\n"
  "\n"
  "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\n"
  "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS\n"
  "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY\n"
  "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE\n"
  "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF\n"
  "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD\n"
  "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),\n"
  "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF\n"
  "SUCH DAMAGES.\n"
  "\n"
  "  17. Interpretation of Sections 15 and 16.\n"
  "\n"
  "  If the disclaimer of warranty and limitation of liability provided\n"
  "above cannot be given local legal effect according to their terms,\n"
  "reviewing courts shall apply local law that most closely approximates\n"
  "an absolute waiver of all civil liability in connection with the\n"
  "Program, unless a warranty or assumption of liability accompanies a\n"
  "copy of the Program in return for a fee.\n"
  "\n"
  "                     END OF TERMS AND CONDITIONS\n"
  "\n"
  "            How to Apply These Terms to Your New Programs\n"
  "\n"
  "  If you develop a new program, and you want it to be of the greatest\n"
  "possible use to the public, the best way to achieve this is to make it\n"
  "free software which everyone can redistribute and change under these terms.\n"
  "\n"
  "  To do so, attach the following notices to the program.  It is safest\n"
  "to attach them to the start of each source file to most effectively\n"
  "state the exclusion of warranty; and each file should have at least\n"
  "the \"copyright\" line and a pointer to where the full notice is found.\n"
  "\n"
  "    <one line to give the program's name and a brief idea of what it does.>\n"
  "    Copyright (C) <year>  <name of author>\n"
  "\n"
  "    This program is free software: you can redistribute it and/or modify\n"
  "    it under the terms of the GNU General Public License as published by\n"
  "    the Free Software Foundation, either version 3 of the License, or\n"
  "    (at your option) any later version.\n"
  "\n"
  "    This program is distributed in the hope that it will be useful,\n"
  "    but WITHOUT ANY WARRANTY; without even the implied warranty of\n"
  "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n"
  "    GNU General Public License for more details.\n"
  "\n"
  "    You should have received a copy of the GNU General Public License\n"
  "    along with this program.  If not, see <http://www.gnu.org/licenses/>.\n"
  "\n"
  "Also add information on how to contact you by electronic and paper mail.\n"
  "\n"
  "  If the program does terminal interaction, make it output a short\n"
  "notice like this when it starts in an interactive mode:\n"
  "\n"
  "    <program>  Copyright (C) <year>  <name of author>\n"
  "    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.\n"
  "    This is free software, and you are welcome to redistribute it\n"
  "    under certain conditions; type `show c' for details.\n"
  "\n"
  "The hypothetical commands `show w' and `show c' should show the appropriate\n"
  "parts of the General Public License.  Of course, your program's commands\n"
  "might be different; for a GUI interface, you would use an \"about box\".\n"
  "\n"
  "  You should also get your employer (if you work as a programmer) or school,\n"
  "if any, to sign a \"copyright disclaimer\" for the program, if necessary.\n"
  "For more information on this, and how to apply and follow the GNU GPL, see\n"
  "<http://www.gnu.org/licenses/>.\n"
  "\n"
  "  The GNU General Public License does not permit incorporating your program\n"
  "into proprietary programs.  If your program is a subroutine library, you\n"
  "may consider it more useful to permit linking proprietary applications with\n"
  "the library.  If this is what you want to do, use the GNU Lesser General\n"
  "Public License instead of this License.  But first, please read\n"
  "<http://www.gnu.org/philosophy/why-not-lgpl.html>.\n"
;
