Had to fix up .gitignore for some conflicts.
guile-config/guile-config
guile-readline/guile-readline-config.h
guile-readline/guile-readline-config.h.in
+*.go
TAGS
guile-1.8.pc
AUTOMAKE_OPTIONS = 1.10
SUBDIRS = lib oop libguile ice-9 guile-config guile-readline emacs \
- scripts srfi doc examples test-suite benchmark-suite lang am
+ scripts srfi doc examples test-suite benchmark-suite lang am \
+ src module testsuite
bin_SCRIPTS = guile-tools
--- /dev/null
+Guile-VM NEWS
+
+
+Guile-VM is a bytecode compiler and virtual machine for Guile.
+
+
+guile-vm 0.7 -- 2008-05-20
+==========================
+
+* Initial release with NEWS.
+
+* Revived from Keisuke Nishida's Guile-VM project from 2000-2001, with
+ the help of Ludovic Courtès.
+
+* Meta-level changes
+** Updated to compile with Guile 1.8.
+** Documentation updated, including documentation on the instructions.
+** Added benchmarking and a test harness.
+
+* Changes to the inventory
+** Renamed the library from libguilevm to libguile-vm.
+** Added new executable script, guile-disasm.
+
+* New features
+** Add support for compiling macros, both defmacros and syncase macros.
+Primitive macros produced with the procedure->macro family of procedures
+are not supported, however.
+** Improvements to the REPL
+Multiple values support, readline integration, ice-9 history integration
+** Add support for eval-case
+The compiler recognizes compile-toplevel in addition to load-toplevel
+** Completely self-compiling
+Almost, anyway: not (system repl describe), because it uses GOOPS
+
+* Internal cleanups
+** Internal objects are now based on Guile records.
+** Guile-VM's code doesn't use the dot-syntax any more.
+** Changed (ice-9 match) for Kiselyov's pmatch.scm
+** New instructions: define, link-later, link-now, late-variable-{ref,set}
+** Object code now represented as u8vectors instead of strings.
+** Remove local import of an old version of slib
+
+* Bugfixes
+** The `optimize' procedure is coming out of bitrot
+** The Scheme compiler is now more strict about placement of internal
+ defines
+** set! is now compiled differently from define
+** Module-level variables are now bound at first use instead of in the
+ program prolog
+** Bugfix to load-program (stack misinterpretation)
+
+
+Copyright (C) 2008 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification, are
+permitted in any medium without royalty provided the copyright notice
+and this notice are preserved.
--- /dev/null
+This is an attempt to revive the Guile-VM project by Keisuke Nishida
+written back in the years 2000 and 2001. Below are a few pointers to
+relevant threads on Guile's development mailing list.
+
+Enjoy!
+
+Ludovic Courtès <ludovic.courtes@laas.fr>, Apr. 2005.
+
+
+Pointers
+--------
+
+Status of the last release, 0.5
+ http://lists.gnu.org/archive/html/guile-devel/2001-04/msg00266.html
+
+The very first release, 0.0
+ http://sources.redhat.com/ml/guile/2000-07/msg00418.html
+
+Simple benchmark
+ http://sources.redhat.com/ml/guile/2000-07/msg00425.html
+
+Performance, portability, GNU Lightning
+ http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00132.html
+
+Playing with GNU Lightning
+ http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00185.html
+
+On things left to be done
+ http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00146.html
+
+
+---8<--- Original README below. -----------------------------------------
+
+Installation
+------------
+
+1. Install the latest Guile from CVS.
+
+2. Install Guile VM:
+
+ % configure
+ % make install
+ % ln -s module/{guile,system,language} /usr/local/share/guile/
+
+3. Add the following lines to your ~/.guile:
+
+ (use-modules (system vm core)
+
+ (cond ((string=? (car (command-line)) "guile-vm")
+ (use-modules (system repl repl))
+ (start-repl 'scheme)
+ (quit)))
+
+Example Session
+---------------
+
+ % guile-vm
+ Guile Scheme interpreter 0.5 on Guile 1.4.1
+ Copyright (C) 2001 Free Software Foundation, Inc.
+
+ Enter `,help' for help.
+ scheme@guile-user> (+ 1 2)
+ 3
+ scheme@guile-user> ,c -c (+ 1 2) ;; Compile into GLIL
+ (@asm (0 1 0 0)
+ (module-ref #f +)
+ (const 1)
+ (const 2)
+ (tail-call 2))
+ scheme@guile-user> ,c (+ 1 2) ;; Compile into object code
+ Disassembly of #<objcode 403c5fb0>:
+
+ nlocs = 0 nexts = 0
+
+ 0 link "+" ;; (+ . ???)
+ 3 variable-ref
+ 4 make-int8:1 ;; 1
+ 5 make-int8 2 ;; 2
+ 7 tail-call 2
+
+ scheme@guile-user> (define (add x y) (+ x y))
+ scheme@guile-user> (add 1 2)
+ 3
+ scheme@guile-user> ,x add ;; Disassemble
+ Disassembly of #<program add>:
+
+ nargs = 2 nrest = 0 nlocs = 0 nexts = 0
+
+ Bytecode:
+
+ 0 object-ref 0 ;; (+ . #<primitive-procedure +>)
+ 2 variable-ref
+ 3 local-ref 0
+ 5 local-ref 1
+ 7 tail-call 2
+
+ Objects:
+
+ 0 (+ . #<primitive-procedure +>)
+
+ scheme@guile-user>
+
+Compile Modules
+---------------
+
+Use `guilec' to compile your modules:
+
+ % cat fib.scm
+ (define-module (fib) :export (fib))
+ (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
+
+ % guilec fib.scm
+ Wrote fib.go
+ % guile
+ guile> (use-modules (fib))
+ guile> (fib 8)
+ 34
--- /dev/null
+Guile VM was inspired by QScheme, librep, and Objective Caml.
--- /dev/null
+;; -*- Scheme -*-
+;;
+;; A library of dumb functions that may be used to benchmark Guile-VM.
+
+
+;; The comments are from Ludovic, a while ago. The speedups now are much
+;; more significant (all over 2x, sometimes 8x).
+
+(define (fibo x)
+ (if (or (= x 1) (= x 2))
+ 1
+ (+ (fibo (- x 1))
+ (fibo (- x 2)))))
+
+(define (g-c-d x y)
+ (if (= x y)
+ x
+ (if (< x y)
+ (g-c-d x (- y x))
+ (g-c-d (- x y) y))))
+
+(define (loop n)
+ ;; This one shows that procedure calls are no faster than within the
+ ;; interpreter: the VM yields no performance improvement.
+ (if (= 0 n)
+ 0
+ (loop (1- n))))
+
+;; Disassembly of `loop'
+;;
+;; Disassembly of #<objcode b79bdf28>:
+
+;; nlocs = 0 nexts = 0
+
+;; 0 (make-int8 64) ;; 64
+;; 2 (load-symbol "guile-user") ;; guile-user
+;; 14 (list 0 1) ;; 1 element
+;; 17 (load-symbol "loop") ;; loop
+;; 23 (link-later)
+;; 24 (vector 0 1) ;; 1 element
+;; 27 (make-int8 0) ;; 0
+;; 29 (load-symbol "n") ;; n
+;; 32 (make-false) ;; #f
+;; 33 (make-int8 0) ;; 0
+;; 35 (list 0 3) ;; 3 elements
+;; 38 (list 0 2) ;; 2 elements
+;; 41 (list 0 1) ;; 1 element
+;; 44 (make-int8 5) ;; 5
+;; 46 (make-false) ;; #f
+;; 47 (cons)
+;; 48 (make-int8 18) ;; 18
+;; 50 (make-false) ;; #f
+;; 51 (cons)
+;; 52 (make-int8 20) ;; 20
+;; 54 (make-false) ;; #f
+;; 55 (cons)
+;; 56 (list 0 4) ;; 4 elements
+;; 59 (load-program ##{66}#)
+;; 81 (define "loop")
+;; 87 (variable-set)
+;; 88 (void)
+;; 89 (return)
+
+;; Bytecode ##{66}#:
+
+;; 0 (make-int8 0) ;; 0
+;; 2 (local-ref 0)
+;; 4 (ee?)
+;; 5 (br-if-not 0 3) ;; -> 11
+;; 8 (make-int8 0) ;; 0
+;; 10 (return)
+;; 11 (late-variable-ref 0)
+;; 13 (local-ref 0)
+;; 15 (make-int8 1) ;; 1
+;; 17 (sub)
+;; 18 (tail-call 1)
+
+(define (loopi n)
+ ;; Same as `loop'.
+ (let loopi ((n n))
+ (if (= 0 n)
+ 0
+ (loopi (1- n)))))
+
+(define (do-loop n)
+ ;; Same as `loop' using `do'.
+ (do ((i n (1- i)))
+ ((= 0 i))
+ ;; do nothing
+ ))
+
+
+(define (do-cons x)
+ ;; This one shows that the built-in `cons' instruction yields a significant
+ ;; improvement (speedup: 1.5).
+ (let loop ((x x)
+ (result '()))
+ (if (<= x 0)
+ result
+ (loop (1- x) (cons x result)))))
+
+(define big-list (iota 500000))
+
+(define (copy-list lst)
+ ;; Speedup: 5.9.
+ (let loop ((lst lst)
+ (result '()))
+ (if (null? lst)
+ result
+ (loop (cdr lst)
+ (cons (car lst) result)))))
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(measure)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+
+;; A simple interpreter vs. VM performance comparison tool
+;;
+
+(define-module (measure)
+ :export (measure)
+ :use-module (system vm vm)
+ :use-module (system vm disasm)
+ :use-module (system base compile)
+ :use-module (system base language))
+
+
+(define (time-for-eval sexp eval)
+ (let ((before (tms:utime (times))))
+ (eval sexp)
+ (let ((elapsed (- (tms:utime (times)) before)))
+ (format #t "elapsed time: ~a~%" elapsed)
+ elapsed)))
+
+(define *scheme* (lookup-language 'scheme))
+
+\f
+(define (measure . args)
+ (if (< (length args) 2)
+ (begin
+ (format #t "Usage: measure SEXP FILE-TO-LOAD...~%")
+ (format #t "~%")
+ (format #t "Example: measure '(loop 23424)' lib.scm~%~%")
+ (exit 1)))
+ (for-each load (cdr args))
+ (let* ((sexp (with-input-from-string (car args)
+ (lambda ()
+ (read))))
+ (eval-here (lambda (sexp) (eval sexp (current-module))))
+ (proc-name (car sexp))
+ (proc-source (procedure-source (eval proc-name (current-module))))
+ (% (format #t "proc: ~a~%source: ~a~%" proc-name proc-source))
+ (time-interpreted (time-for-eval sexp eval-here))
+ (& (if (defined? proc-name)
+ (eval `(set! ,proc-name #f) (current-module))
+ (format #t "unbound~%")))
+ (objcode (compile-in proc-source
+ (current-module) *scheme*))
+ (the-program (vm-load (the-vm) objcode))
+
+; (%%% (disassemble-objcode objcode))
+ (time-compiled (time-for-eval `(,proc-name ,@(cdr sexp))
+ (lambda (sexp)
+ (eval `(begin
+ (define ,proc-name
+ ,the-program)
+ ,sexp)
+ (current-module))))))
+
+ (format #t "proc: ~a => ~a~%"
+ proc-name (eval proc-name (current-module)))
+ (format #t "interpreted: ~a~%" time-interpreted)
+ (format #t "compiled: ~a~%" time-compiled)
+ (format #t "speedup: ~a~%"
+ (exact->inexact (/ time-interpreted time-compiled)))
+ 0))
+
+(define main measure)
AC_C_BIGENDIAN
+AC_C_LABELS_AS_VALUES
+
AC_CHECK_SIZEOF(char)
AC_CHECK_SIZEOF(unsigned char)
AC_CHECK_SIZEOF(short)
srfi/Makefile
test-suite/Makefile
test-suite/standalone/Makefile
+ src/Makefile
+ module/Makefile
+ module/system/Makefile
+ module/system/base/Makefile
+ module/system/vm/Makefile
+ module/system/il/Makefile
+ module/system/repl/Makefile
+ module/language/Makefile
+ module/language/scheme/Makefile
+ testsuite/Makefile
])
AC_CONFIG_FILES([guile-1.8.pc])
( cd $(top_builddir) ; $(mscripts)/update-guile-api.alist )
guile-api.alist-FORCE:
endif
+
+info_TEXINFOS = guile-vm.texi
--- /dev/null
+From: Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+Subject: Re: After GOOPS integration: Computation with native types!
+To: Keisuke Nishida <kxn30@po.cwru.edu>
+Cc: djurfeldt@nada.kth.se, guile@sourceware.cygnus.com
+Cc: djurfeldt@nada.kth.se
+Date: 17 Aug 2000 03:01:13 +0200
+
+Keisuke Nishida <kxn30@po.cwru.edu> writes:
+
+> Do I need to include some special feature in my VM? Hmm, but maybe
+> I shouldn't do that now...
+
+Probably not, so I probably shouldn't answer, but... :)
+
+You'll need to include some extremely efficient mechanism to do
+multi-method dispatch. The SCM_IM_DISPATCH form, with its
+implementation at line 2250 in eval.c, is the current basis for
+efficient dispatch in GOOPS.
+
+I think we should develop a new instruction for the VM which
+corresponds to the SCM_IM_DISPATCH form.
+
+This form serves both the purpose to map argument types to the correct
+code, and as a cache of compiled methods.
+
+Notice that I talk about cmethods below, not methods. In GOOPS, the
+GF has a set of methods, but each method has a "code-table" mapping
+argument types to code compiled for those particular concrete types.
+(So, in essence, GOOPS methods abstractly do a deeper level of type
+dispatch.)
+
+The SCM_IM_DISPATCH form has two shapes, depending on whether we use
+sequential search (few cmethods) or hashed lookup (many cmethods).
+
+Shape 1:
+
+ (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
+
+Shape 2:
+
+ (#@dispatch args N-SPECIALIZED HASHSET MASK
+ #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
+ GF)
+
+`args' is (I hope!) a now historic obscure optimization.
+
+N-SPECIALIZED is the maximum number of arguments t do type checking
+on. This is used early termination of argument checking where the
+already checked arguments are enough to pick out the cmethod.
+
+The vector is the cache proper.
+
+During sequential search the argument types are simply checked against
+each entry.
+
+The method for hashed dispatch is described in:
+
+http://www.parc.xerox.com/csl/groups/sda/publications/papers/Kiczales-Andreas-PCL
+
+In this method, each class has a hash code. Dispatch means summing
+the hash codes for all arguments (up til N-SPECIALIZED) and using the
+sum to pick a location in the cache. The cache is sequentially
+searched for an argument type match from that point.
+
+Kiczales introduced a clever method to maximize the probability of a
+direct cache hit. We actually have 8 separate sets of hash codes for
+all types. The hash set to use is selected specifically per GF and is
+optimized to give fastest average hit.
+
+
+What we could try to do as soon as the VM is complete enough is to
+represent the cmethods as chunks of byte code. In the current GOOPS
+code, the compilation step (which is currently empty) is situated in
+`compile-cmethod' in guile-oops/compile.scm. [Apologies for the
+terrible code. That particular part was written at Arlanda airport
+after a sleepless night (packing luggage, not coding), on my way to
+visit Marius (who, BTW, didn't take GOOPS seriously. ;-)]
+
--- /dev/null
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename guile-vm.info
+@settitle Guile VM Specification
+@footnotestyle end
+@setchapternewpage odd
+@c %**end of header
+
+@set EDITION 0.6
+@set VERSION 0.6
+@set UPDATED 2005-04-26
+
+@c Macro for instruction definitions.
+@macro insn{}
+Instruction
+@end macro
+
+@c For Scheme procedure definitions.
+@macro scmproc{}
+Scheme Procedure
+@end macro
+
+@c Scheme records.
+@macro scmrec{}
+Record
+@end macro
+
+@ifinfo
+@dircategory Scheme Programming
+@direntry
+* Guile VM: (guile-vm). Guile's Virtual Machine.
+@end direntry
+
+This file documents Guile VM.
+
+Copyright @copyright{} 2000 Keisuke Nishida
+Copyright @copyright{} 2005 Ludovic Court`es
+
+Permission is granted to make and distribute verbatim copies of this
+manual provided the copyright notice and this permission notice are
+preserved on all copies.
+
+@ignore
+Permission is granted to process this file through TeX and print the
+results, provided the printed document carries a copying permission
+notice identical to this one except for the removal of this paragraph
+(this paragraph not being relevant to the printed manual).
+
+@end ignore
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the
+entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions,
+except that this permission notice may be stated in a translation
+approved by the Free Software Foundation.
+@end ifinfo
+
+@titlepage
+@title Guile VM Specification
+@subtitle for Guile VM @value{VERSION}
+@author Keisuke Nishida
+
+@page
+@vskip 0pt plus 1filll
+Edition @value{EDITION} @*
+Updated for Guile VM @value{VERSION} @*
+@value{UPDATED} @*
+
+Copyright @copyright{} 2000 Keisuke Nishida
+Copyright @copyright{} 2005 Ludovic Court`es
+
+Permission is granted to make and distribute verbatim copies of this
+manual provided the copyright notice and this permission notice are
+preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the
+entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions,
+except that this permission notice may be stated in a translation
+approved by the Free Software Foundation.
+@end titlepage
+
+@contents
+
+@c *********************************************************************
+@node Top, Introduction, (dir), (dir)
+@top Guile VM Specification
+
+This document would like to correspond to Guile VM @value{VERSION}.
+However, be warned that important parts still correspond to version
+0.0 and are not valid anymore.
+
+@menu
+* Introduction::
+* Variable Management::
+* Instruction Set::
+* The Compiler::
+* Concept Index::
+* Function and Instruction Index::
+* Command and Variable Index::
+
+@detailmenu
+ --- The Detailed Node Listing ---
+
+Instruction Set
+
+* Environment Control Instructions::
+* Branch Instructions::
+* Subprogram Control Instructions::
+* Data Control Instructions::
+
+The Compiler
+
+* Overview::
+* The Language Front-Ends::
+* GHIL::
+* Compiling Scheme Code::
+* GLIL::
+* The Assembler::
+
+@end detailmenu
+@end menu
+
+@c *********************************************************************
+@node Introduction, Variable Management, Top, Top
+@chapter What is Guile VM?
+
+A Guile VM has a set of registers and its own stack memory. Guile may
+have more than one VM's. Each VM may execute at most one program at a
+time. Guile VM is a CISC system so designed as to execute Scheme and
+other languages efficiently.
+
+@unnumberedsubsec Registers
+
+@itemize
+@item pc - Program counter ;; ip (instruction poiner) is better?
+@item sp - Stack pointer
+@item bp - Base pointer
+@item ac - Accumulator
+@end itemize
+
+@unnumberedsubsec Engine
+
+A VM may have one of three engines: reckless, regular, or debugging.
+Reckless engine is fastest but dangerous. Regular engine is normally
+fail-safe and reasonably fast. Debugging engine is safest and
+functional but very slow.
+
+@unnumberedsubsec Memory
+
+Stack is the only memory that each VM owns. The other memory is shared
+memory that is shared among every VM and other part of Guile.
+
+@unnumberedsubsec Program
+
+A VM program consists of a bytecode that is executed and an environment
+in which execution is done. Each program is allocated in the shared
+memory and may be executed by any VM. A program may call other programs
+within a VM.
+
+@unnumberedsubsec Instruction
+
+Guile VM has dozens of system instructions and (possibly) hundreds of
+functional instructions. Some Scheme procedures such as cons and car
+are implemented as VM's builtin functions, which are very efficient.
+Other procedures defined outside of the VM are also considered as VM's
+functional features, since they do not change the state of VM.
+Procedures defined within the VM are called subprograms.
+
+Most instructions deal with the accumulator (ac). The VM stores all
+results from functions in ac, instead of pushing them into the stack.
+I'm not sure whether this is a good thing or not.
+
+@node Variable Management, Instruction Set, Introduction, Top
+@chapter Variable Management
+
+FIXME: This chapter needs to be reviewed so that it matches reality.
+A more up-to-date description of the mechanisms described in this
+section is given in @ref{Instruction Set}.
+
+A program may have access to local variables, external variables, and
+top-level variables.
+
+@section Local/external variables
+
+A stack is logically divided into several blocks during execution. A
+"block" is such a unit that maintains local variables and dynamic chain.
+A "frame" is an upper level unit that maintains subprogram calls.
+
+@example
+ Stack
+ dynamic | | | |
+ chain +==========+ - =
+ | |local vars| | |
+ `-|block data| | block |
+ /|frame data| | |
+ | +----------+ - |
+ | |local vars| | | frame
+ `-|block data| | |
+ /+----------+ - |
+ | |local vars| | |
+ `-|block data| | |
+ /+==========+ - =
+ | |local vars| | |
+ `-|block data| | |
+ /|frame data| | |
+ | +----------+ - |
+ | | | | |
+@end example
+
+The first block of each frame may look like this:
+
+@example
+ Address Data
+ ------- ----
+ xxx0028 Local variable 2
+ xxx0024 Local variable 1
+ bp ->xxx0020 Local variable 0
+ xxx001c Local link (block data)
+ xxx0018 External link (block data)
+ xxx0014 Stack pointer (block data)
+ xxx0010 Return address (frame data)
+ xxx000c Parent program (frame data)
+@end example
+
+The base pointer (bp) always points to the lowest address of local
+variables of the recent block. Local variables are referred as "bp[n]".
+The local link field has a pointer to the dynamic parent of the block.
+The parent's variables are referred as "bp[-1][n]", and grandparent's
+are "bp[-1][-1][n]". Thus, any local variable is represented by its
+depth and offset from the current bp.
+
+A variable may be "external", which is allocated in the shared memory.
+The external link field of a block has a pointer to such a variable set,
+which I call "fragment" (what should I call?). A fragment has a set of
+variables and its own chain.
+
+@example
+ local external
+ chain| | chain
+ | +-----+ .--------, |
+ `-|block|--+->|external|-'
+ /+-----+ | `--------'\,
+ `-|block|--' |
+ /+-----+ .--------, |
+ `-|block|---->|external|-'
+ +-----+ `--------'
+ | |
+@end example
+
+An external variable is referred as "bp[-2]->variables[n]" or
+"bp[-2]->link->...->variables[n]". This is also represented by a pair
+of depth and offset. At any point of execution, the value of bp
+determines the current local link and external link, and thus the
+current environment of a program.
+
+Other data fields are described later.
+
+@section Top-level variables
+
+Guile VM uses the same top-level variables as the regular Guile. A
+program may have direct access to vcells. Currently this is done by
+calling scm_intern0, but a program is possible to have any top-level
+environment defined by the current module.
+
+@section Scheme and VM variable
+
+Let's think about the following Scheme code as an example:
+
+@example
+ (define (foo a)
+ (lambda (b) (list foo a b)))
+@end example
+
+In the lambda expression, "foo" is a top-level variable, "a" is an
+external variable, and "b" is a local variable.
+
+When a VM executes foo, it allocates a block for "a". Since "a" may be
+externally referred from the closure, the VM creates a fragment with a
+copy of "a" in it. When the VM evaluates the lambda expression, it
+creates a subprogram (closure), associating the fragment with the
+subprogram as its external environment. When the closure is executed,
+its environment will look like this:
+
+@example
+ block Top-level: foo
+ +-------------+
+ |local var: b | fragment
+ +-------------+ .-----------,
+ |external link|---->|variable: a|
+ +-------------+ `-----------'
+@end example
+
+The fragment remains as long as the closure exists.
+
+@section Addressing mode
+
+Guile VM has five addressing modes:
+
+@itemize
+@item Real address
+@item Local position
+@item External position
+@item Top-level location
+@item Constant object
+@end itemize
+
+Real address points to the address in the real program and is only used
+with the program counter (pc).
+
+Local position and external position are represented as a pair of depth
+and offset from bp, as described above. These are base relative
+addresses, and the real address may vary during execution.
+
+Top-level location is represented as a Guile's vcell. This location is
+determined at loading time, so the use of this address is efficient.
+
+Constant object is not an address but gives an instruction an Scheme
+object directly.
+
+[ We'll also need dynamic scope addressing to support Emacs Lisp? ]
+
+
+Overall procedure:
+
+@enumerate
+@item A source program is compiled into a bytecode.
+@item A bytecode is given an environment and becomes a program.
+@item A VM starts execution, creating a frame for it.
+@item Whenever a program calls a subprogram, a new frame is created for it.
+@item When a program finishes execution, it returns a value, and the VM
+ continues execution of the parent program.
+@item When all programs terminated, the VM returns the final value and stops.
+@end enumerate
+
+\f
+@node Instruction Set, The Compiler, Variable Management, Top
+@chapter Instruction Set
+
+The Guile VM instruction set is roughly divided two groups: system
+instructions and functional instructions. System instructions control
+the execution of programs, while functional instructions provide many
+useful calculations.
+
+@menu
+* Environment Control Instructions::
+* Branch Instructions::
+* Subprogram Control Instructions::
+* Data Control Instructions::
+@end menu
+
+@node Environment Control Instructions, Branch Instructions, Instruction Set, Instruction Set
+@section Environment Control Instructions
+
+@deffn @insn{} link binding-name
+Look up @var{binding-name} (a string) in the current environment and
+push the corresponding variable object onto the stack. If
+@var{binding-name} is not bound yet, then create a new binding and
+push its variable object.
+@end deffn
+
+@deffn @insn{} variable-ref
+Dereference the variable object which is on top of the stack and
+replace it by the value of the variable it represents.
+@end deffn
+
+@deffn @insn{} variable-set
+Set the value of the variable on top of the stack (at @code{sp[0]}) to
+the object located immediately before (at @code{sp[-1]}).
+@end deffn
+
+As an example, let us look at what a simple function call looks like:
+
+@example
+(+ 2 3)
+@end example
+
+This call yields the following sequence of instructions:
+
+@example
+(link "+") ;; lookup binding "+"
+(variable-ref) ;; dereference it
+(make-int8 2) ;; push immediate value `2'
+(make-int8 3) ;; push immediate value `3'
+(tail-call 2) ;; call the proc at sp[-3] with two args
+@end example
+
+@deffn @insn{} local-ref offset
+Push onto the stack the value of the local variable located at
+@var{offset} within the current stack frame.
+@end deffn
+
+@deffn @insn{} local-set offset
+Pop the Scheme object located on top of the stack and make it the new
+value of the local variable located at @var{offset} within the current
+stack frame.
+@end deffn
+
+@deffn @insn{} external-ref offset
+Push the value of the closure variable located at position
+@var{offset} within the program's list of external variables.
+@end deffn
+
+@deffn @insn{} external-set offset
+Pop the Scheme object located on top of the stack and make it the new
+value of the closure variable located at @var{offset} within the
+program's list of external variables.
+@end deffn
+
+@deffn @insn{} make-closure
+Pop the program object from the stack and assign it the current
+closure variable list as its closure. Push the result program
+object.
+@end deffn
+
+Let's illustrate this:
+
+@example
+(let ((x 2))
+ (lambda ()
+ (let ((x++ (+ 1 x)))
+ (set! x x++)
+ x++)))
+@end example
+
+The resulting program has one external (closure) variable, i.e. its
+@var{nexts} is set to 1 (@pxref{Subprogram Control Instructions}).
+This yields the following code:
+
+@example
+ ;; the traditional program prologue with NLOCS = 0 and NEXTS = 1
+
+ 0 (make-int8 2)
+ 2 (external-set 0)
+ 4 (make-int8 4)
+ 6 (link "+") ;; lookup `+'
+ 9 (vector 1) ;; create the external variable vector for
+ ;; later use by `object-ref' and `object-set'
+ ...
+ 40 (load-program ##34#)
+ 59 (make-closure) ;; assign the current closure to the program
+ ;; just pushed by `load-program'
+ 60 (return)
+@end example
+
+The program loaded here by @var{load-program} contains the following
+sequence of instructions:
+
+@example
+ 0 (object-ref 0) ;; push the variable for `+'
+ 2 (variable-ref) ;; dereference `+'
+ 3 (make-int8:1) ;; push 1
+ 4 (external-ref 0) ;; push the value of `x'
+ 6 (call 2) ;; call `+' and push the result
+ 8 (local-set 0) ;; make it the new value of `x++'
+ 10 (local-ref 0) ;; push the value of `x++'
+ 12 (external-set 0) ;; make it the new value of `x'
+ 14 (local-ref 0) ;; push the value of `x++'
+ 16 (return) ;; return it
+@end example
+
+At this point, you should know pretty much everything about the three
+types of variables a program may need to access.
+
+
+@node Branch Instructions, Subprogram Control Instructions, Environment Control Instructions, Instruction Set
+@section Branch Instructions
+
+All the conditional branch instructions described below work in the
+same way:
+
+@itemize
+@item They take the Scheme object located on the stack and use it as
+the branch condition;
+@item If the condition if false, then program execution continues with
+the next instruction;
+@item If the condition is true, then the instruction pointer is
+increased by the offset passed as an argument to the branch
+instruction;
+@item Finally, when the instruction finished, the condition object is
+removed from the stack.
+@end itemize
+
+Note that the offset passed to the instruction is encoded on two 8-bit
+integers which are then combined by the VM as one 16-bit integer.
+
+@deffn @insn{} br offset
+Jump to @var{offset}.
+@end deffn
+
+@deffn @insn{} br-if offset
+Jump to @var{offset} if the condition on the stack is not false.
+@end deffn
+
+@deffn @insn{} br-if-not offset
+Jump to @var{offset} if the condition on the stack is false.
+@end deffn
+
+@deffn @insn{} br-if-eq offset
+Jump to @var{offset} if the two objects located on the stack are
+equal in the sense of @var{eq?}. Note that, for this instruction, the
+stack pointer is decremented by two Scheme objects instead of only
+one.
+@end deffn
+
+@deffn @insn{} br-if-not-eq offset
+Same as @var{br-if-eq} for non-equal objects.
+@end deffn
+
+@deffn @insn{} br-if-null offset
+Jump to @var{offset} if the object on the stack is @code{'()}.
+@end deffn
+
+@deffn @insn{} br-if-not-null offset
+Jump to @var{offset} if the object on the stack is not @code{'()}.
+@end deffn
+
+
+@node Subprogram Control Instructions, Data Control Instructions, Branch Instructions, Instruction Set
+@section Subprogram Control Instructions
+
+Programs (read: ``compiled procedure'') may refer to external
+bindings, like variables or functions defined outside the program
+itself, in the environment in which it will evaluate at run-time. In
+a sense, a program's environment and its bindings are an implicit
+parameter of every program.
+
+@cindex object table
+In order to handle such bindings, each program has an @dfn{object
+table} associated to it. This table (actually a Scheme vector)
+contains all constant objects referenced by the program. The object
+table of a program is initialized right before a program is loaded
+with @var{load-program}.
+
+Variable objects are one such type of constant object: when a global
+binding is defined, a variable object is associated to it and that
+object will remain constant over time, even if the value bound to it
+changes. Therefore, external bindings only need to be looked up once
+when the program is loaded. References to the corresponding external
+variables from within the program are then performed via the
+@var{object-ref} instruction and are almost as fast as local variable
+references.
+
+Let us consider the following program (procedure) which references
+external bindings @code{frob} and @var{%magic}:
+
+@example
+(lambda (x)
+ (frob x %magic))
+@end example
+
+This yields the following assembly code:
+
+@example
+(make-int8 64) ;; number of args, vars, etc. (see below)
+(link "frob")
+(link "%magic")
+(vector 2) ;; object table (external bindings)
+...
+(load-program #u8(20 0 23 21 0 20 1 23 36 2))
+(return)
+@end example
+
+All the instructions occurring before @var{load-program} (some were
+omitted for simplicity) form a @dfn{prologue} which, among other
+things, pushed an object table (a vector) that contains the variable
+objects for the variables bound to @var{frob} and @var{%magic}. This
+vector and other data pushed onto the stack are then popped by the
+@var{load-program} instruction.
+
+Besides, the @var{load-program} instruction takes one explicit
+argument which is the bytecode of the program itself. Disassembled,
+this bytecode looks like:
+
+@example
+(object-ref 0) ;; push the variable object of `frob'
+(variable-ref) ;; dereference it
+(local-ref 0) ;; push the value of `x'
+(object-ref 1) ;; push the variable object of `%magic'
+(variable-ref) ;; dereference it
+(tail-call 2) ;; call `frob' with two parameters
+@end example
+
+This clearly shows that there is little difference between references
+to local variables and references to externally bound variables since
+lookup of externally bound variables if performed only once before the
+program is run.
+
+@deffn @insn{} load-program bytecode
+Load the program whose bytecode is @var{bytecode} (a u8vector), pop
+its meta-information from the stack, and push a corresponding program
+object onto the stack. The program's meta-information may consist of
+(in the order in which it should be pushed onto the stack):
+
+@itemize
+@item optionally, a pair representing meta-data (see the
+@var{program-meta} procedure); [FIXME: explain their meaning]
+@item optionally, a vector which is the program's object table (a
+program that does not reference external bindings does not need an
+object table);
+@item either one immediate integer or four immediate integers
+representing respectively the number of arguments taken by the
+function (@var{nargs}), the number of @dfn{rest arguments}
+(@var{nrest}, 0 or 1), the number of local variables (@var{nlocs}) and
+the number of external variables (@var{nexts}) (@pxref{Environment
+Control Instructions}).
+@end itemize
+
+@end deffn
+
+@deffn @insn{} object-ref offset
+Push the variable object for the external variable located at
+@var{offset} within the program's object table.
+@end deffn
+
+@deffn @insn{} return
+Free the program's frame.
+@end deffn
+
+@deffn @insn{} call nargs
+Call the procedure, continuation or program located at
+@code{sp[-nargs]} with the @var{nargs} arguments located from
+@code{sp[0]} to @code{sp[-nargs + 1]}. The
+procedure/continuation/program and its arguments are dropped from the
+stack and the result is pushed. When calling a program, the
+@code{call} instruction reserves room for its local variables on the
+stack, and initializes its list of closure variables and its vector of
+externally bound variables.
+@end deffn
+
+@deffn @insn{} tail-call nargs
+Same as @code{call} except that, for tail-recursive calls to a
+program, the current stack frame is re-used, as required by RnRS.
+This instruction is otherwise similar to @code{call}.
+@end deffn
+
+
+@node Data Control Instructions, , Subprogram Control Instructions, Instruction Set
+@section Data Control Instructions
+
+@deffn @insn{} make-int8 value
+Push @var{value}, an 8-bit integer, onto the stack.
+@end deffn
+
+@deffn @insn{} make-int8:0
+Push the immediate value @code{0} onto the stack.
+@end deffn
+
+@deffn @insn{} make-int8:1
+Push the immediate value @code{1} onto the stack.
+@end deffn
+
+@deffn @insn{} make-false
+Push @code{#f} onto the stack.
+@end deffn
+
+@deffn @insn{} make-true
+Push @code{#t} onto the stack.
+@end deffn
+
+@itemize
+@item %push
+@item %pushi
+@item %pushl, %pushl:0:0, %pushl:0:1, %pushl:0:2, %pushl:0:3
+@item %pushe, %pushe:0:0, %pushe:0:1, %pushe:0:2, %pushe:0:3
+@item %pusht
+@end itemize
+
+@itemize
+@item %loadi
+@item %loadl, %loadl:0:0, %loadl:0:1, %loadl:0:2, %loadl:0:3
+@item %loade, %loade:0:0, %loade:0:1, %loade:0:2, %loade:0:3
+@item %loadt
+@end itemize
+
+@itemize
+@item %savei
+@item %savel, %savel:0:0, %savel:0:1, %savel:0:2, %savel:0:3
+@item %savee, %savee:0:0, %savee:0:1, %savee:0:2, %savee:0:3
+@item %savet
+@end itemize
+
+@section Flow control instructions
+
+@itemize
+@item %br-if
+@item %br-if-not
+@item %jump
+@end itemize
+
+@section Function call instructions
+
+@itemize
+@item %func, %func0, %func1, %func2
+@end itemize
+
+@section Scheme built-in functions
+
+@itemize
+@item cons
+@item car
+@item cdr
+@end itemize
+
+@section Mathematical buitin functions
+
+@itemize
+@item 1+
+@item 1-
+@item add, add2
+@item sub, sub2, minus
+@item mul2
+@item div2
+@item lt2
+@item gt2
+@item le2
+@item ge2
+@item num-eq2
+@end itemize
+
+
+\f
+@node The Compiler, Concept Index, Instruction Set, Top
+@chapter The Compiler
+
+This section describes Guile-VM's compiler and the compilation process
+to produce bytecode executable by the VM itself (@pxref{Instruction
+Set}).
+
+@menu
+* Overview::
+* The Language Front-Ends::
+* GHIL::
+* Compiling Scheme Code::
+* GLIL::
+* The Assembler::
+@end menu
+
+@node Overview, The Language Front-Ends, The Compiler, The Compiler
+@section Overview
+
+Compilation in Guile-VM is a three-stage process:
+
+@cindex intermediate language
+@cindex assembler
+@cindex compiler
+@cindex GHIL
+@cindex GLIL
+@cindex bytecode
+
+@enumerate
+@item the source programming language (e.g. R5RS Scheme) is read and
+translated into GHIL, @dfn{Guile's High-Level Intermediate Language};
+@item GHIL code is then translated into a lower-level intermediate
+language call GLIL, @dfn{Guile's Low-Level Intermediate Language};
+@item finally, GLIL is @dfn{assembled} into the VM's assembly language
+(@pxref{Instruction Set}) and bytecode.
+@end enumerate
+
+The use of two separate intermediate languages eases the
+implementation of front-ends since the gap between high-level
+languages like Scheme and GHIL is relatively small.
+
+@vindex guilec
+From an end-user viewpoint, compiling a Guile program into bytecode
+can be done either by using the @command{guilec} command-line tool, or
+by using the @code{compile-file} procedure exported by the
+@code{(system base compile)} module.
+
+@deffn @scmproc{} compile-file file . opts
+Compile Scheme source code from file @var{file} using compilation
+options @var{opts}. The resulting file, a Guile object file, will be
+name according the application of the @code{compiled-file-name}
+procedure to @var{file}. The possible values for @var{opts} are the
+same as for the @code{compile-in} procedure (see below, @pxref{The Language
+Front-Ends}).
+@end deffn
+
+@deffn @scmproc{} compiled-file-name file
+Given source file name @var{file} (a string), return a string that
+denotes the name of the Guile object file corresponding to
+@var{file}. By default, the file name returned is @var{file} minus
+its extension and plus the @code{.go} file extension.
+@end deffn
+
+@cindex self-hosting
+It is worth noting, as you might have already guessed, that Guile-VM's
+compiler is written in Guile Scheme and is @dfn{self-hosted}: it can
+compile itself.
+
+@node The Language Front-Ends, GHIL, Overview, The Compiler
+@section The Language Front-Ends
+
+Guile-VM comes with a number of @dfn{language front-ends}, that is,
+code that can read a given high-level programming language like R5RS
+Scheme, and translate it into a lower-level representation suitable to
+the compiler.
+
+Each language front-end provides a @dfn{specification} and a
+@dfn{translator} to GHIL. Both of them come in the @code{language}
+module hierarchy. As an example, the front-end for Scheme is located
+in the @code{(language scheme spec)} and @code{(language scheme
+translate)} modules. Language front-ends can then be retrieved using
+the @code{lookup-language} procedure of the @code{(system base
+language)} module.
+
+@deftp @scmrec{} <language> name title version reader printer read-file expander translator evaluator environment
+Denotes a language front-end specification a various methods used by
+the compiler to handle source written in that language. Of particular
+interest is the @code{translator} slot (@pxref{GHIL}).
+@end deftp
+
+@deffn @scmproc{} lookup-language lang
+Look for a language front-end named @var{lang}, a symbol (e.g,
+@code{scheme}), and return the @code{<language>} record describing it
+if found. If @var{lang} does not denote a language front-end, an
+error is raised. Note that this procedure assumes that language
+@var{lang} exists if there exist a @code{(language @var{lang} spec)}
+module.
+@end deffn
+
+The @code{(system base compile)} module defines a procedure similar to
+@code{compile-file} but that is not limited to the Scheme language:
+
+@deffn @scmproc{} compile-in expr env lang . opts
+Compile expression @var{expr}, which is written in language @var{lang}
+(a @code{<language>} object), using compilation options @var{opts},
+and return bytecode as produced by the assembler (@pxref{The
+Assembler}).
+
+Options @var{opts} may contain the following keywords:
+
+@table @code
+@item :e
+compilation will stop after the code expansion phase.
+@item :t
+compilation will stop after the code translation phase, i.e. after
+code in the source language @var{lang} has been translated into GHIL
+(@pxref{GHIL}).
+@item :c
+compilation will stop after the compilation phase and before the
+assembly phase, i.e. once GHIL has been translated into GLIL
+(@pxref{GLIL}).
+@end table
+
+Additionally, @var{opts} may contain any option understood by the
+GHIL-to-GLIL compiler described in @xref{GLIL}.
+@end deffn
+
+
+@node GHIL, Compiling Scheme Code, The Language Front-Ends, The Compiler
+@section Guile's High-Level Intermediate Language
+
+GHIL has constructs almost equivalent to those found in Scheme.
+However, unlike Scheme, it is meant to be read only by the compiler
+itself. Therefore, a sequence of GHIL code is only a sequence of GHIL
+@emph{objects} (records), as opposed to symbols, each of which
+represents a particular language feature. These records are all
+defined in the @code{(system il ghil)} module and are named
+@code{<ghil-*>}.
+
+Each GHIL record has at least two fields: one containing the
+environment (Guile module) in which it is considered, and one
+containing its location [FIXME: currently seems to be unused]. Below
+is a list of the main GHIL object types and their fields:
+
+@example
+;; Objects
+(<ghil-void> env loc)
+(<ghil-quote> env loc obj)
+(<ghil-quasiquote> env loc exp)
+(<ghil-unquote> env loc exp)
+(<ghil-unquote-splicing> env loc exp)
+;; Variables
+(<ghil-ref> env loc var)
+(<ghil-set> env loc var val)
+(<ghil-define> env loc var val)
+;; Controls
+(<ghil-if> env loc test then else)
+(<ghil-and> env loc exps)
+(<ghil-or> env loc exps)
+(<ghil-begin> env loc exps)
+(<ghil-bind> env loc vars vals body)
+(<ghil-lambda> env loc vars rest body)
+(<ghil-call> env loc proc args)
+(<ghil-inline> env loc inline args)
+@end example
+
+As can be seen from this examples, the constructs in GHIL are pretty
+close to the fundamental primitives of Scheme.
+
+It is the role of front-end language translators (@pxref{The Language
+Front-Ends}) to produce a sequence of GHIL objects from the
+human-readable, source programming language. The next section
+describes the translator for the Scheme language.
+
+@node Compiling Scheme Code, GLIL, GHIL, The Compiler
+@section Compiling Scheme Code
+
+The language object for Scheme, as returned by @code{(lookup-language
+'scheme)} (@pxref{The Language Front-Ends}), defines a translator
+procedure that returns a sequence of GHIL objects given Scheme code.
+Before actually performing this operation, the Scheme translator
+expands macros in the original source code.
+
+The macros that may be expanded can come from different sources:
+
+@itemize
+@item core Guile macros, such as @code{false-if-exception};
+@item macros defined in modules used by the module being compiled,
+e.g., @code{receive} in @code{(ice-9 receive)};
+@item macros defined within the module being compiled.
+@end itemize
+
+@cindex macro
+@cindex syntax transformer
+@findex define-macro
+@findex defmacro
+The main complexity in handling macros at compilation time is that
+Guile's macros are first-class objects. For instance, when using
+@code{define-macro}, one actually defines a @emph{procedure} that
+returns code; of course, unlike a ``regular'' procedure, it is
+executed when an S-exp is @dfn{memoized} by the evaluator, i.e.,
+before the actual evaluation takes place. Worse, it is possible to
+turn a procedure into a macro, or @dfn{syntax transformer}, thus
+removing, to some extent, the boundary between the macro expansion and
+evaluation phases, @inforef{Internal Macros, , guile}.
+
+[FIXME: explain limitations, etc.]
+
+
+@node GLIL, The Assembler, Compiling Scheme Code, The Compiler
+@section Guile's Low-Level Intermediate Language
+
+A GHIL instruction sequence can be compiled into GLIL using the
+@code{compile} procedure exported by the @code{(system il compile)}
+module. During this translation process, various optimizations may
+also be performed.
+
+The module @code{(system il glil)} defines record types representing
+various low-level abstractions. Compared to GHIL, the flow control
+primitives in GLIL are much more low-level: only @code{<glil-label>},
+@code{<glil-branch>} and @code{<glil-call>} are available, no
+@code{lambda}, @code{if}, etc.
+
+
+@deffn @scmproc{} compile ghil environment . opts
+Compile @var{ghil}, a GHIL instruction sequence, within
+environment/module @var{environment}, and return the resulting GLIL
+instruction sequence. The option list @var{opts} may be either the
+empty list or a list containing the @code{:O} keyword in which case
+@code{compile} will first go through an optimization stage of
+@var{ghil}.
+
+Note that the @code{:O} option may be passed at a higher-level to the
+@code{compile-file} and @code{compile-in} procedures (@pxref{The
+Language Front-Ends}).
+@end deffn
+
+@deffn @scmproc{} pprint-glil glil . port
+Print @var{glil}, a GLIL sequence instructions, in a human-readable
+form. If @var{port} is passed, it will be used as the output port.
+@end deffn
+
+
+Let's consider the following Scheme expression:
+
+@example
+(lambda (x) (+ x 1))
+@end example
+
+The corresponding (unoptimized) GLIL code, as shown by
+@code{pprint-glil}, looks like this:
+
+@example
+(@@asm (0 0 0 0)
+ (@@asm (1 0 0 0) ;; expect one arg.
+ (@@bind (x argument 0)) ;; debugging info
+ (module-ref #f +) ;; lookup `+'
+ (argument-ref 0) ;; push the argument onto
+ ;; the stack
+ (const 1) ;; push `1'
+ (tail-call 2) ;; call `+', with 2 args,
+ ;; using the same stack frame
+ (@@source 15 33)) ;; additional debugging info
+ (return 0))
+@end example
+
+This is not unlike the VM's assembly language described in
+@ref{Instruction Set}.
+
+@node The Assembler, , GLIL, The Compiler
+@section The Assembler
+
+@findex code->bytes
+
+The final compilation step consists in converting the GLIL instruction
+sequence into VM bytecode. This is what the @code{assemble} procedure
+defined in the @code{(system vm assemble)} module is for. It relies
+on the @code{code->bytes} procedure of the @code{(system vm conv)}
+module to convert instructions (represented as lists whose @code{car}
+is a symbol naming the instruction, e.g. @code{object-ref},
+@pxref{Instruction Set}) into binary code, or @dfn{bytecode}.
+Bytecode itself is represented using SRFI-4 byte vectors,
+@inforef{SRFI-4, SRFI-4 homogeneous numeric vectors, guile}.
+
+
+@deffn @scmproc{} assemble glil environment . opts
+Return a binary representation of @var{glil} (bytecode), either in the
+form of an SRFI-4 @code{u8vector} or a @code{<bytespec>} object.
+[FIXME: Why is that?]
+@end deffn
+
+
+
+@c *********************************************************************
+@node Concept Index, Function and Instruction Index, The Compiler, Top
+@unnumbered Concept Index
+@printindex cp
+
+@node Function and Instruction Index, Command and Variable Index, Concept Index, Top
+@unnumbered Function and Instruction Index
+@printindex fn
+
+@node Command and Variable Index, , Function and Instruction Index, Top
+@unnumbered Command and Variable Index
+@printindex vr
+
+@bye
+
+@c Local Variables:
+@c ispell-local-dictionary: "american";
+@c End:
+
+@c LocalWords: bytecode
--- /dev/null
+% texinfo.tex -- TeX macros to handle Texinfo files.
+%
+% Load plain if necessary, i.e., if running under initex.
+\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
+%
+\def\texinfoversion{2007-12-02.17}
+%
+% Copyright (C) 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995, 2007,
+% 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+% 2007 Free Software Foundation, Inc.
+%
+% This texinfo.tex file is free software: you can redistribute it and/or
+% modify it under the terms of the GNU General Public License as
+% published by the Free Software Foundation, either version 3 of the
+% License, or (at your option) any later version.
+%
+% This texinfo.tex file is distributed in the hope that it will be
+% useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+% of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+% General Public License for more details.
+%
+% You should have received a copy of the GNU General Public License
+% along with this program. If not, see <http://www.gnu.org/licenses/>.
+%
+% As a special exception, when this file is read by TeX when processing
+% a Texinfo source document, you may use the result without
+% restriction. (This has been our intent since Texinfo was invented.)
+%
+% Please try the latest version of texinfo.tex before submitting bug
+% reports; you can get the latest version from:
+% http://www.gnu.org/software/texinfo/ (the Texinfo home page), or
+% ftp://tug.org/tex/texinfo.tex
+% (and all CTAN mirrors, see http://www.ctan.org).
+% The texinfo.tex in any given distribution could well be out
+% of date, so if that's what you're using, please check.
+%
+% Send bug reports to bug-texinfo@gnu.org. Please include including a
+% complete document in each bug report with which we can reproduce the
+% problem. Patches are, of course, greatly appreciated.
+%
+% To process a Texinfo manual with TeX, it's most reliable to use the
+% texi2dvi shell script that comes with the distribution. For a simple
+% manual foo.texi, however, you can get away with this:
+% tex foo.texi
+% texindex foo.??
+% tex foo.texi
+% tex foo.texi
+% dvips foo.dvi -o # or whatever; this makes foo.ps.
+% The extra TeX runs get the cross-reference information correct.
+% Sometimes one run after texindex suffices, and sometimes you need more
+% than two; texi2dvi does it as many times as necessary.
+%
+% It is possible to adapt texinfo.tex for other languages, to some
+% extent. You can get the existing language-specific files from the
+% full Texinfo distribution.
+%
+% The GNU Texinfo home page is http://www.gnu.org/software/texinfo.
+
+
+\message{Loading texinfo [version \texinfoversion]:}
+
+% If in a .fmt file, print the version number
+% and turn on active characters that we couldn't do earlier because
+% they might have appeared in the input file name.
+\everyjob{\message{[Texinfo version \texinfoversion]}%
+ \catcode`+=\active \catcode`\_=\active}
+
+
+\chardef\other=12
+
+% We never want plain's \outer definition of \+ in Texinfo.
+% For @tex, we can use \tabalign.
+\let\+ = \relax
+
+% Save some plain tex macros whose names we will redefine.
+\let\ptexb=\b
+\let\ptexbullet=\bullet
+\let\ptexc=\c
+\let\ptexcomma=\,
+\let\ptexdot=\.
+\let\ptexdots=\dots
+\let\ptexend=\end
+\let\ptexequiv=\equiv
+\let\ptexexclam=\!
+\let\ptexfootnote=\footnote
+\let\ptexgtr=>
+\let\ptexhat=^
+\let\ptexi=\i
+\let\ptexindent=\indent
+\let\ptexinsert=\insert
+\let\ptexlbrace=\{
+\let\ptexless=<
+\let\ptexnewwrite\newwrite
+\let\ptexnoindent=\noindent
+\let\ptexplus=+
+\let\ptexrbrace=\}
+\let\ptexslash=\/
+\let\ptexstar=\*
+\let\ptext=\t
+
+% If this character appears in an error message or help string, it
+% starts a new line in the output.
+\newlinechar = `^^J
+
+% Use TeX 3.0's \inputlineno to get the line number, for better error
+% messages, but if we're using an old version of TeX, don't do anything.
+%
+\ifx\inputlineno\thisisundefined
+ \let\linenumber = \empty % Pre-3.0.
+\else
+ \def\linenumber{l.\the\inputlineno:\space}
+\fi
+
+% Set up fixed words for English if not already set.
+\ifx\putwordAppendix\undefined \gdef\putwordAppendix{Appendix}\fi
+\ifx\putwordChapter\undefined \gdef\putwordChapter{Chapter}\fi
+\ifx\putwordfile\undefined \gdef\putwordfile{file}\fi
+\ifx\putwordin\undefined \gdef\putwordin{in}\fi
+\ifx\putwordIndexIsEmpty\undefined \gdef\putwordIndexIsEmpty{(Index is empty)}\fi
+\ifx\putwordIndexNonexistent\undefined \gdef\putwordIndexNonexistent{(Index is nonexistent)}\fi
+\ifx\putwordInfo\undefined \gdef\putwordInfo{Info}\fi
+\ifx\putwordInstanceVariableof\undefined \gdef\putwordInstanceVariableof{Instance Variable of}\fi
+\ifx\putwordMethodon\undefined \gdef\putwordMethodon{Method on}\fi
+\ifx\putwordNoTitle\undefined \gdef\putwordNoTitle{No Title}\fi
+\ifx\putwordof\undefined \gdef\putwordof{of}\fi
+\ifx\putwordon\undefined \gdef\putwordon{on}\fi
+\ifx\putwordpage\undefined \gdef\putwordpage{page}\fi
+\ifx\putwordsection\undefined \gdef\putwordsection{section}\fi
+\ifx\putwordSection\undefined \gdef\putwordSection{Section}\fi
+\ifx\putwordsee\undefined \gdef\putwordsee{see}\fi
+\ifx\putwordSee\undefined \gdef\putwordSee{See}\fi
+\ifx\putwordShortTOC\undefined \gdef\putwordShortTOC{Short Contents}\fi
+\ifx\putwordTOC\undefined \gdef\putwordTOC{Table of Contents}\fi
+%
+\ifx\putwordMJan\undefined \gdef\putwordMJan{January}\fi
+\ifx\putwordMFeb\undefined \gdef\putwordMFeb{February}\fi
+\ifx\putwordMMar\undefined \gdef\putwordMMar{March}\fi
+\ifx\putwordMApr\undefined \gdef\putwordMApr{April}\fi
+\ifx\putwordMMay\undefined \gdef\putwordMMay{May}\fi
+\ifx\putwordMJun\undefined \gdef\putwordMJun{June}\fi
+\ifx\putwordMJul\undefined \gdef\putwordMJul{July}\fi
+\ifx\putwordMAug\undefined \gdef\putwordMAug{August}\fi
+\ifx\putwordMSep\undefined \gdef\putwordMSep{September}\fi
+\ifx\putwordMOct\undefined \gdef\putwordMOct{October}\fi
+\ifx\putwordMNov\undefined \gdef\putwordMNov{November}\fi
+\ifx\putwordMDec\undefined \gdef\putwordMDec{December}\fi
+%
+\ifx\putwordDefmac\undefined \gdef\putwordDefmac{Macro}\fi
+\ifx\putwordDefspec\undefined \gdef\putwordDefspec{Special Form}\fi
+\ifx\putwordDefvar\undefined \gdef\putwordDefvar{Variable}\fi
+\ifx\putwordDefopt\undefined \gdef\putwordDefopt{User Option}\fi
+\ifx\putwordDeffunc\undefined \gdef\putwordDeffunc{Function}\fi
+
+% Since the category of space is not known, we have to be careful.
+\chardef\spacecat = 10
+\def\spaceisspace{\catcode`\ =\spacecat}
+
+% sometimes characters are active, so we need control sequences.
+\chardef\colonChar = `\:
+\chardef\commaChar = `\,
+\chardef\dashChar = `\-
+\chardef\dotChar = `\.
+\chardef\exclamChar= `\!
+\chardef\lquoteChar= `\`
+\chardef\questChar = `\?
+\chardef\rquoteChar= `\'
+\chardef\semiChar = `\;
+\chardef\underChar = `\_
+
+% Ignore a token.
+%
+\def\gobble#1{}
+
+% The following is used inside several \edef's.
+\def\makecsname#1{\expandafter\noexpand\csname#1\endcsname}
+
+% Hyphenation fixes.
+\hyphenation{
+ Flor-i-da Ghost-script Ghost-view Mac-OS Post-Script
+ ap-pen-dix bit-map bit-maps
+ data-base data-bases eshell fall-ing half-way long-est man-u-script
+ man-u-scripts mini-buf-fer mini-buf-fers over-view par-a-digm
+ par-a-digms rath-er rec-tan-gu-lar ro-bot-ics se-vere-ly set-up spa-ces
+ spell-ing spell-ings
+ stand-alone strong-est time-stamp time-stamps which-ever white-space
+ wide-spread wrap-around
+}
+
+% Margin to add to right of even pages, to left of odd pages.
+\newdimen\bindingoffset
+\newdimen\normaloffset
+\newdimen\pagewidth \newdimen\pageheight
+
+% For a final copy, take out the rectangles
+% that mark overfull boxes (in case you have decided
+% that the text looks ok even though it passes the margin).
+%
+\def\finalout{\overfullrule=0pt}
+
+% @| inserts a changebar to the left of the current line. It should
+% surround any changed text. This approach does *not* work if the
+% change spans more than two lines of output. To handle that, we would
+% have adopt a much more difficult approach (putting marks into the main
+% vertical list for the beginning and end of each change).
+%
+\def\|{%
+ % \vadjust can only be used in horizontal mode.
+ \leavevmode
+ %
+ % Append this vertical mode material after the current line in the output.
+ \vadjust{%
+ % We want to insert a rule with the height and depth of the current
+ % leading; that is exactly what \strutbox is supposed to record.
+ \vskip-\baselineskip
+ %
+ % \vadjust-items are inserted at the left edge of the type. So
+ % the \llap here moves out into the left-hand margin.
+ \llap{%
+ %
+ % For a thicker or thinner bar, change the `1pt'.
+ \vrule height\baselineskip width1pt
+ %
+ % This is the space between the bar and the text.
+ \hskip 12pt
+ }%
+ }%
+}
+
+% Sometimes it is convenient to have everything in the transcript file
+% and nothing on the terminal. We don't just call \tracingall here,
+% since that produces some useless output on the terminal. We also make
+% some effort to order the tracing commands to reduce output in the log
+% file; cf. trace.sty in LaTeX.
+%
+\def\gloggingall{\begingroup \globaldefs = 1 \loggingall \endgroup}%
+\def\loggingall{%
+ \tracingstats2
+ \tracingpages1
+ \tracinglostchars2 % 2 gives us more in etex
+ \tracingparagraphs1
+ \tracingoutput1
+ \tracingmacros2
+ \tracingrestores1
+ \showboxbreadth\maxdimen \showboxdepth\maxdimen
+ \ifx\eTeXversion\undefined\else % etex gives us more logging
+ \tracingscantokens1
+ \tracingifs1
+ \tracinggroups1
+ \tracingnesting2
+ \tracingassigns1
+ \fi
+ \tracingcommands3 % 3 gives us more in etex
+ \errorcontextlines16
+}%
+
+% add check for \lastpenalty to plain's definitions. If the last thing
+% we did was a \nobreak, we don't want to insert more space.
+%
+\def\smallbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\smallskipamount
+ \removelastskip\penalty-50\smallskip\fi\fi}
+\def\medbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\medskipamount
+ \removelastskip\penalty-100\medskip\fi\fi}
+\def\bigbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\bigskipamount
+ \removelastskip\penalty-200\bigskip\fi\fi}
+
+% For @cropmarks command.
+% Do @cropmarks to get crop marks.
+%
+\newif\ifcropmarks
+\let\cropmarks = \cropmarkstrue
+%
+% Dimensions to add cropmarks at corners.
+% Added by P. A. MacKay, 12 Nov. 1986
+%
+\newdimen\outerhsize \newdimen\outervsize % set by the paper size routines
+\newdimen\cornerlong \cornerlong=1pc
+\newdimen\cornerthick \cornerthick=.3pt
+\newdimen\topandbottommargin \topandbottommargin=.75in
+
+% Output a mark which sets \thischapter, \thissection and \thiscolor.
+% We dump everything together because we only have one kind of mark.
+% This works because we only use \botmark / \topmark, not \firstmark.
+%
+% A mark contains a subexpression of the \ifcase ... \fi construct.
+% \get*marks macros below extract the needed part using \ifcase.
+%
+% Another complication is to let the user choose whether \thischapter
+% (\thissection) refers to the chapter (section) in effect at the top
+% of a page, or that at the bottom of a page. The solution is
+% described on page 260 of The TeXbook. It involves outputting two
+% marks for the sectioning macros, one before the section break, and
+% one after. I won't pretend I can describe this better than DEK...
+\def\domark{%
+ \toks0=\expandafter{\lastchapterdefs}%
+ \toks2=\expandafter{\lastsectiondefs}%
+ \toks4=\expandafter{\prevchapterdefs}%
+ \toks6=\expandafter{\prevsectiondefs}%
+ \toks8=\expandafter{\lastcolordefs}%
+ \mark{%
+ \the\toks0 \the\toks2
+ \noexpand\or \the\toks4 \the\toks6
+ \noexpand\else \the\toks8
+ }%
+}
+% \topmark doesn't work for the very first chapter (after the title
+% page or the contents), so we use \firstmark there -- this gets us
+% the mark with the chapter defs, unless the user sneaks in, e.g.,
+% @setcolor (or @url, or @link, etc.) between @contents and the very
+% first @chapter.
+\def\gettopheadingmarks{%
+ \ifcase0\topmark\fi
+ \ifx\thischapter\empty \ifcase0\firstmark\fi \fi
+}
+\def\getbottomheadingmarks{\ifcase1\botmark\fi}
+\def\getcolormarks{\ifcase2\topmark\fi}
+
+% Avoid "undefined control sequence" errors.
+\def\lastchapterdefs{}
+\def\lastsectiondefs{}
+\def\prevchapterdefs{}
+\def\prevsectiondefs{}
+\def\lastcolordefs{}
+
+% Main output routine.
+\chardef\PAGE = 255
+\output = {\onepageout{\pagecontents\PAGE}}
+
+\newbox\headlinebox
+\newbox\footlinebox
+
+% \onepageout takes a vbox as an argument. Note that \pagecontents
+% does insertions, but you have to call it yourself.
+\def\onepageout#1{%
+ \ifcropmarks \hoffset=0pt \else \hoffset=\normaloffset \fi
+ %
+ \ifodd\pageno \advance\hoffset by \bindingoffset
+ \else \advance\hoffset by -\bindingoffset\fi
+ %
+ % Do this outside of the \shipout so @code etc. will be expanded in
+ % the headline as they should be, not taken literally (outputting ''code).
+ \ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi
+ \setbox\headlinebox = \vbox{\let\hsize=\pagewidth \makeheadline}%
+ \ifodd\pageno \getoddfootingmarks \else \getevenfootingmarks \fi
+ \setbox\footlinebox = \vbox{\let\hsize=\pagewidth \makefootline}%
+ %
+ {%
+ % Have to do this stuff outside the \shipout because we want it to
+ % take effect in \write's, yet the group defined by the \vbox ends
+ % before the \shipout runs.
+ %
+ \indexdummies % don't expand commands in the output.
+ \normalturnoffactive % \ in index entries must not stay \, e.g., if
+ % the page break happens to be in the middle of an example.
+ % We don't want .vr (or whatever) entries like this:
+ % \entry{{\tt \indexbackslash }acronym}{32}{\code {\acronym}}
+ % "\acronym" won't work when it's read back in;
+ % it needs to be
+ % {\code {{\tt \backslashcurfont }acronym}
+ \shipout\vbox{%
+ % Do this early so pdf references go to the beginning of the page.
+ \ifpdfmakepagedest \pdfdest name{\the\pageno} xyz\fi
+ %
+ \ifcropmarks \vbox to \outervsize\bgroup
+ \hsize = \outerhsize
+ \vskip-\topandbottommargin
+ \vtop to0pt{%
+ \line{\ewtop\hfil\ewtop}%
+ \nointerlineskip
+ \line{%
+ \vbox{\moveleft\cornerthick\nstop}%
+ \hfill
+ \vbox{\moveright\cornerthick\nstop}%
+ }%
+ \vss}%
+ \vskip\topandbottommargin
+ \line\bgroup
+ \hfil % center the page within the outer (page) hsize.
+ \ifodd\pageno\hskip\bindingoffset\fi
+ \vbox\bgroup
+ \fi
+ %
+ \unvbox\headlinebox
+ \pagebody{#1}%
+ \ifdim\ht\footlinebox > 0pt
+ % Only leave this space if the footline is nonempty.
+ % (We lessened \vsize for it in \oddfootingyyy.)
+ % The \baselineskip=24pt in plain's \makefootline has no effect.
+ \vskip 24pt
+ \unvbox\footlinebox
+ \fi
+ %
+ \ifcropmarks
+ \egroup % end of \vbox\bgroup
+ \hfil\egroup % end of (centering) \line\bgroup
+ \vskip\topandbottommargin plus1fill minus1fill
+ \boxmaxdepth = \cornerthick
+ \vbox to0pt{\vss
+ \line{%
+ \vbox{\moveleft\cornerthick\nsbot}%
+ \hfill
+ \vbox{\moveright\cornerthick\nsbot}%
+ }%
+ \nointerlineskip
+ \line{\ewbot\hfil\ewbot}%
+ }%
+ \egroup % \vbox from first cropmarks clause
+ \fi
+ }% end of \shipout\vbox
+ }% end of group with \indexdummies
+ \advancepageno
+ \ifnum\outputpenalty>-20000 \else\dosupereject\fi
+}
+
+\newinsert\margin \dimen\margin=\maxdimen
+
+\def\pagebody#1{\vbox to\pageheight{\boxmaxdepth=\maxdepth #1}}
+{\catcode`\@ =11
+\gdef\pagecontents#1{\ifvoid\topins\else\unvbox\topins\fi
+% marginal hacks, juha@viisa.uucp (Juha Takala)
+\ifvoid\margin\else % marginal info is present
+ \rlap{\kern\hsize\vbox to\z@{\kern1pt\box\margin \vss}}\fi
+\dimen@=\dp#1\relax \unvbox#1\relax
+\ifvoid\footins\else\vskip\skip\footins\footnoterule \unvbox\footins\fi
+\ifr@ggedbottom \kern-\dimen@ \vfil \fi}
+}
+
+% Here are the rules for the cropmarks. Note that they are
+% offset so that the space between them is truly \outerhsize or \outervsize
+% (P. A. MacKay, 12 November, 1986)
+%
+\def\ewtop{\vrule height\cornerthick depth0pt width\cornerlong}
+\def\nstop{\vbox
+ {\hrule height\cornerthick depth\cornerlong width\cornerthick}}
+\def\ewbot{\vrule height0pt depth\cornerthick width\cornerlong}
+\def\nsbot{\vbox
+ {\hrule height\cornerlong depth\cornerthick width\cornerthick}}
+
+% Parse an argument, then pass it to #1. The argument is the rest of
+% the input line (except we remove a trailing comment). #1 should be a
+% macro which expects an ordinary undelimited TeX argument.
+%
+\def\parsearg{\parseargusing{}}
+\def\parseargusing#1#2{%
+ \def\argtorun{#2}%
+ \begingroup
+ \obeylines
+ \spaceisspace
+ #1%
+ \parseargline\empty% Insert the \empty token, see \finishparsearg below.
+}
+
+{\obeylines %
+ \gdef\parseargline#1^^M{%
+ \endgroup % End of the group started in \parsearg.
+ \argremovecomment #1\comment\ArgTerm%
+ }%
+}
+
+% First remove any @comment, then any @c comment.
+\def\argremovecomment#1\comment#2\ArgTerm{\argremovec #1\c\ArgTerm}
+\def\argremovec#1\c#2\ArgTerm{\argcheckspaces#1\^^M\ArgTerm}
+
+% Each occurence of `\^^M' or `<space>\^^M' is replaced by a single space.
+%
+% \argremovec might leave us with trailing space, e.g.,
+% @end itemize @c foo
+% This space token undergoes the same procedure and is eventually removed
+% by \finishparsearg.
+%
+\def\argcheckspaces#1\^^M{\argcheckspacesX#1\^^M \^^M}
+\def\argcheckspacesX#1 \^^M{\argcheckspacesY#1\^^M}
+\def\argcheckspacesY#1\^^M#2\^^M#3\ArgTerm{%
+ \def\temp{#3}%
+ \ifx\temp\empty
+ % Do not use \next, perhaps the caller of \parsearg uses it; reuse \temp:
+ \let\temp\finishparsearg
+ \else
+ \let\temp\argcheckspaces
+ \fi
+ % Put the space token in:
+ \temp#1 #3\ArgTerm
+}
+
+% If a _delimited_ argument is enclosed in braces, they get stripped; so
+% to get _exactly_ the rest of the line, we had to prevent such situation.
+% We prepended an \empty token at the very beginning and we expand it now,
+% just before passing the control to \argtorun.
+% (Similarily, we have to think about #3 of \argcheckspacesY above: it is
+% either the null string, or it ends with \^^M---thus there is no danger
+% that a pair of braces would be stripped.
+%
+% But first, we have to remove the trailing space token.
+%
+\def\finishparsearg#1 \ArgTerm{\expandafter\argtorun\expandafter{#1}}
+
+% \parseargdef\foo{...}
+% is roughly equivalent to
+% \def\foo{\parsearg\Xfoo}
+% \def\Xfoo#1{...}
+%
+% Actually, I use \csname\string\foo\endcsname, ie. \\foo, as it is my
+% favourite TeX trick. --kasal, 16nov03
+
+\def\parseargdef#1{%
+ \expandafter \doparseargdef \csname\string#1\endcsname #1%
+}
+\def\doparseargdef#1#2{%
+ \def#2{\parsearg#1}%
+ \def#1##1%
+}
+
+% Several utility definitions with active space:
+{
+ \obeyspaces
+ \gdef\obeyedspace{ }
+
+ % Make each space character in the input produce a normal interword
+ % space in the output. Don't allow a line break at this space, as this
+ % is used only in environments like @example, where each line of input
+ % should produce a line of output anyway.
+ %
+ \gdef\sepspaces{\obeyspaces\let =\tie}
+
+ % If an index command is used in an @example environment, any spaces
+ % therein should become regular spaces in the raw index file, not the
+ % expansion of \tie (\leavevmode \penalty \@M \ ).
+ \gdef\unsepspaces{\let =\space}
+}
+
+
+\def\flushcr{\ifx\par\lisppar \def\next##1{}\else \let\next=\relax \fi \next}
+
+% Define the framework for environments in texinfo.tex. It's used like this:
+%
+% \envdef\foo{...}
+% \def\Efoo{...}
+%
+% It's the responsibility of \envdef to insert \begingroup before the
+% actual body; @end closes the group after calling \Efoo. \envdef also
+% defines \thisenv, so the current environment is known; @end checks
+% whether the environment name matches. The \checkenv macro can also be
+% used to check whether the current environment is the one expected.
+%
+% Non-false conditionals (@iftex, @ifset) don't fit into this, so they
+% are not treated as enviroments; they don't open a group. (The
+% implementation of @end takes care not to call \endgroup in this
+% special case.)
+
+
+% At runtime, environments start with this:
+\def\startenvironment#1{\begingroup\def\thisenv{#1}}
+% initialize
+\let\thisenv\empty
+
+% ... but they get defined via ``\envdef\foo{...}'':
+\long\def\envdef#1#2{\def#1{\startenvironment#1#2}}
+\def\envparseargdef#1#2{\parseargdef#1{\startenvironment#1#2}}
+
+% Check whether we're in the right environment:
+\def\checkenv#1{%
+ \def\temp{#1}%
+ \ifx\thisenv\temp
+ \else
+ \badenverr
+ \fi
+}
+
+% Evironment mismatch, #1 expected:
+\def\badenverr{%
+ \errhelp = \EMsimple
+ \errmessage{This command can appear only \inenvironment\temp,
+ not \inenvironment\thisenv}%
+}
+\def\inenvironment#1{%
+ \ifx#1\empty
+ out of any environment%
+ \else
+ in environment \expandafter\string#1%
+ \fi
+}
+
+% @end foo executes the definition of \Efoo.
+% But first, it executes a specialized version of \checkenv
+%
+\parseargdef\end{%
+ \if 1\csname iscond.#1\endcsname
+ \else
+ % The general wording of \badenverr may not be ideal, but... --kasal, 06nov03
+ \expandafter\checkenv\csname#1\endcsname
+ \csname E#1\endcsname
+ \endgroup
+ \fi
+}
+
+\newhelp\EMsimple{Press RETURN to continue.}
+
+
+%% Simple single-character @ commands
+
+% @@ prints an @
+% Kludge this until the fonts are right (grr).
+\def\@{{\tt\char64}}
+
+% This is turned off because it was never documented
+% and you can use @w{...} around a quote to suppress ligatures.
+%% Define @` and @' to be the same as ` and '
+%% but suppressing ligatures.
+%\def\`{{`}}
+%\def\'{{'}}
+
+% Used to generate quoted braces.
+\def\mylbrace {{\tt\char123}}
+\def\myrbrace {{\tt\char125}}
+\let\{=\mylbrace
+\let\}=\myrbrace
+\begingroup
+ % Definitions to produce \{ and \} commands for indices,
+ % and @{ and @} for the aux/toc files.
+ \catcode`\{ = \other \catcode`\} = \other
+ \catcode`\[ = 1 \catcode`\] = 2
+ \catcode`\! = 0 \catcode`\\ = \other
+ !gdef!lbracecmd[\{]%
+ !gdef!rbracecmd[\}]%
+ !gdef!lbraceatcmd[@{]%
+ !gdef!rbraceatcmd[@}]%
+!endgroup
+
+% @comma{} to avoid , parsing problems.
+\let\comma = ,
+
+% Accents: @, @dotaccent @ringaccent @ubaraccent @udotaccent
+% Others are defined by plain TeX: @` @' @" @^ @~ @= @u @v @H.
+\let\, = \c
+\let\dotaccent = \.
+\def\ringaccent#1{{\accent23 #1}}
+\let\tieaccent = \t
+\let\ubaraccent = \b
+\let\udotaccent = \d
+
+% Other special characters: @questiondown @exclamdown @ordf @ordm
+% Plain TeX defines: @AA @AE @O @OE @L (plus lowercase versions) @ss.
+\def\questiondown{?`}
+\def\exclamdown{!`}
+\def\ordf{\leavevmode\raise1ex\hbox{\selectfonts\lllsize \underbar{a}}}
+\def\ordm{\leavevmode\raise1ex\hbox{\selectfonts\lllsize \underbar{o}}}
+
+% Dotless i and dotless j, used for accents.
+\def\imacro{i}
+\def\jmacro{j}
+\def\dotless#1{%
+ \def\temp{#1}%
+ \ifx\temp\imacro \ptexi
+ \else\ifx\temp\jmacro \j
+ \else \errmessage{@dotless can be used only with i or j}%
+ \fi\fi
+}
+
+% The \TeX{} logo, as in plain, but resetting the spacing so that a
+% period following counts as ending a sentence. (Idea found in latex.)
+%
+\edef\TeX{\TeX \spacefactor=1000 }
+
+% @LaTeX{} logo. Not quite the same results as the definition in
+% latex.ltx, since we use a different font for the raised A; it's most
+% convenient for us to use an explicitly smaller font, rather than using
+% the \scriptstyle font (since we don't reset \scriptstyle and
+% \scriptscriptstyle).
+%
+\def\LaTeX{%
+ L\kern-.36em
+ {\setbox0=\hbox{T}%
+ \vbox to \ht0{\hbox{\selectfonts\lllsize A}\vss}}%
+ \kern-.15em
+ \TeX
+}
+
+% Be sure we're in horizontal mode when doing a tie, since we make space
+% equivalent to this in @example-like environments. Otherwise, a space
+% at the beginning of a line will start with \penalty -- and
+% since \penalty is valid in vertical mode, we'd end up putting the
+% penalty on the vertical list instead of in the new paragraph.
+{\catcode`@ = 11
+ % Avoid using \@M directly, because that causes trouble
+ % if the definition is written into an index file.
+ \global\let\tiepenalty = \@M
+ \gdef\tie{\leavevmode\penalty\tiepenalty\ }
+}
+
+% @: forces normal size whitespace following.
+\def\:{\spacefactor=1000 }
+
+% @* forces a line break.
+\def\*{\hfil\break\hbox{}\ignorespaces}
+
+% @/ allows a line break.
+\let\/=\allowbreak
+
+% @. is an end-of-sentence period.
+\def\.{.\spacefactor=\endofsentencespacefactor\space}
+
+% @! is an end-of-sentence bang.
+\def\!{!\spacefactor=\endofsentencespacefactor\space}
+
+% @? is an end-of-sentence query.
+\def\?{?\spacefactor=\endofsentencespacefactor\space}
+
+% @frenchspacing on|off says whether to put extra space after punctuation.
+%
+\def\onword{on}
+\def\offword{off}
+%
+\parseargdef\frenchspacing{%
+ \def\temp{#1}%
+ \ifx\temp\onword \plainfrenchspacing
+ \else\ifx\temp\offword \plainnonfrenchspacing
+ \else
+ \errhelp = \EMsimple
+ \errmessage{Unknown @frenchspacing option `\temp', must be on/off}%
+ \fi\fi
+}
+
+% @w prevents a word break. Without the \leavevmode, @w at the
+% beginning of a paragraph, when TeX is still in vertical mode, would
+% produce a whole line of output instead of starting the paragraph.
+\def\w#1{\leavevmode\hbox{#1}}
+
+% @group ... @end group forces ... to be all on one page, by enclosing
+% it in a TeX vbox. We use \vtop instead of \vbox to construct the box
+% to keep its height that of a normal line. According to the rules for
+% \topskip (p.114 of the TeXbook), the glue inserted is
+% max (\topskip - \ht (first item), 0). If that height is large,
+% therefore, no glue is inserted, and the space between the headline and
+% the text is small, which looks bad.
+%
+% Another complication is that the group might be very large. This can
+% cause the glue on the previous page to be unduly stretched, because it
+% does not have much material. In this case, it's better to add an
+% explicit \vfill so that the extra space is at the bottom. The
+% threshold for doing this is if the group is more than \vfilllimit
+% percent of a page (\vfilllimit can be changed inside of @tex).
+%
+\newbox\groupbox
+\def\vfilllimit{0.7}
+%
+\envdef\group{%
+ \ifnum\catcode`\^^M=\active \else
+ \errhelp = \groupinvalidhelp
+ \errmessage{@group invalid in context where filling is enabled}%
+ \fi
+ \startsavinginserts
+ %
+ \setbox\groupbox = \vtop\bgroup
+ % Do @comment since we are called inside an environment such as
+ % @example, where each end-of-line in the input causes an
+ % end-of-line in the output. We don't want the end-of-line after
+ % the `@group' to put extra space in the output. Since @group
+ % should appear on a line by itself (according to the Texinfo
+ % manual), we don't worry about eating any user text.
+ \comment
+}
+%
+% The \vtop produces a box with normal height and large depth; thus, TeX puts
+% \baselineskip glue before it, and (when the next line of text is done)
+% \lineskip glue after it. Thus, space below is not quite equal to space
+% above. But it's pretty close.
+\def\Egroup{%
+ % To get correct interline space between the last line of the group
+ % and the first line afterwards, we have to propagate \prevdepth.
+ \endgraf % Not \par, as it may have been set to \lisppar.
+ \global\dimen1 = \prevdepth
+ \egroup % End the \vtop.
+ % \dimen0 is the vertical size of the group's box.
+ \dimen0 = \ht\groupbox \advance\dimen0 by \dp\groupbox
+ % \dimen2 is how much space is left on the page (more or less).
+ \dimen2 = \pageheight \advance\dimen2 by -\pagetotal
+ % if the group doesn't fit on the current page, and it's a big big
+ % group, force a page break.
+ \ifdim \dimen0 > \dimen2
+ \ifdim \pagetotal < \vfilllimit\pageheight
+ \page
+ \fi
+ \fi
+ \box\groupbox
+ \prevdepth = \dimen1
+ \checkinserts
+}
+%
+% TeX puts in an \escapechar (i.e., `@') at the beginning of the help
+% message, so this ends up printing `@group can only ...'.
+%
+\newhelp\groupinvalidhelp{%
+group can only be used in environments such as @example,^^J%
+where each line of input produces a line of output.}
+
+% @need space-in-mils
+% forces a page break if there is not space-in-mils remaining.
+
+\newdimen\mil \mil=0.001in
+
+% Old definition--didn't work.
+%\parseargdef\need{\par %
+%% This method tries to make TeX break the page naturally
+%% if the depth of the box does not fit.
+%{\baselineskip=0pt%
+%\vtop to #1\mil{\vfil}\kern -#1\mil\nobreak
+%\prevdepth=-1000pt
+%}}
+
+\parseargdef\need{%
+ % Ensure vertical mode, so we don't make a big box in the middle of a
+ % paragraph.
+ \par
+ %
+ % If the @need value is less than one line space, it's useless.
+ \dimen0 = #1\mil
+ \dimen2 = \ht\strutbox
+ \advance\dimen2 by \dp\strutbox
+ \ifdim\dimen0 > \dimen2
+ %
+ % Do a \strut just to make the height of this box be normal, so the
+ % normal leading is inserted relative to the preceding line.
+ % And a page break here is fine.
+ \vtop to #1\mil{\strut\vfil}%
+ %
+ % TeX does not even consider page breaks if a penalty added to the
+ % main vertical list is 10000 or more. But in order to see if the
+ % empty box we just added fits on the page, we must make it consider
+ % page breaks. On the other hand, we don't want to actually break the
+ % page after the empty box. So we use a penalty of 9999.
+ %
+ % There is an extremely small chance that TeX will actually break the
+ % page at this \penalty, if there are no other feasible breakpoints in
+ % sight. (If the user is using lots of big @group commands, which
+ % almost-but-not-quite fill up a page, TeX will have a hard time doing
+ % good page breaking, for example.) However, I could not construct an
+ % example where a page broke at this \penalty; if it happens in a real
+ % document, then we can reconsider our strategy.
+ \penalty9999
+ %
+ % Back up by the size of the box, whether we did a page break or not.
+ \kern -#1\mil
+ %
+ % Do not allow a page break right after this kern.
+ \nobreak
+ \fi
+}
+
+% @br forces paragraph break (and is undocumented).
+
+\let\br = \par
+
+% @page forces the start of a new page.
+%
+\def\page{\par\vfill\supereject}
+
+% @exdent text....
+% outputs text on separate line in roman font, starting at standard page margin
+
+% This records the amount of indent in the innermost environment.
+% That's how much \exdent should take out.
+\newskip\exdentamount
+
+% This defn is used inside fill environments such as @defun.
+\parseargdef\exdent{\hfil\break\hbox{\kern -\exdentamount{\rm#1}}\hfil\break}
+
+% This defn is used inside nofill environments such as @example.
+\parseargdef\nofillexdent{{\advance \leftskip by -\exdentamount
+ \leftline{\hskip\leftskip{\rm#1}}}}
+
+% @inmargin{WHICH}{TEXT} puts TEXT in the WHICH margin next to the current
+% paragraph. For more general purposes, use the \margin insertion
+% class. WHICH is `l' or `r'.
+%
+\newskip\inmarginspacing \inmarginspacing=1cm
+\def\strutdepth{\dp\strutbox}
+%
+\def\doinmargin#1#2{\strut\vadjust{%
+ \nobreak
+ \kern-\strutdepth
+ \vtop to \strutdepth{%
+ \baselineskip=\strutdepth
+ \vss
+ % if you have multiple lines of stuff to put here, you'll need to
+ % make the vbox yourself of the appropriate size.
+ \ifx#1l%
+ \llap{\ignorespaces #2\hskip\inmarginspacing}%
+ \else
+ \rlap{\hskip\hsize \hskip\inmarginspacing \ignorespaces #2}%
+ \fi
+ \null
+ }%
+}}
+\def\inleftmargin{\doinmargin l}
+\def\inrightmargin{\doinmargin r}
+%
+% @inmargin{TEXT [, RIGHT-TEXT]}
+% (if RIGHT-TEXT is given, use TEXT for left page, RIGHT-TEXT for right;
+% else use TEXT for both).
+%
+\def\inmargin#1{\parseinmargin #1,,\finish}
+\def\parseinmargin#1,#2,#3\finish{% not perfect, but better than nothing.
+ \setbox0 = \hbox{\ignorespaces #2}%
+ \ifdim\wd0 > 0pt
+ \def\lefttext{#1}% have both texts
+ \def\righttext{#2}%
+ \else
+ \def\lefttext{#1}% have only one text
+ \def\righttext{#1}%
+ \fi
+ %
+ \ifodd\pageno
+ \def\temp{\inrightmargin\righttext}% odd page -> outside is right margin
+ \else
+ \def\temp{\inleftmargin\lefttext}%
+ \fi
+ \temp
+}
+
+% @include file insert text of that file as input.
+%
+\def\include{\parseargusing\filenamecatcodes\includezzz}
+\def\includezzz#1{%
+ \pushthisfilestack
+ \def\thisfile{#1}%
+ {%
+ \makevalueexpandable
+ \def\temp{\input #1 }%
+ \expandafter
+ }\temp
+ \popthisfilestack
+}
+\def\filenamecatcodes{%
+ \catcode`\\=\other
+ \catcode`~=\other
+ \catcode`^=\other
+ \catcode`_=\other
+ \catcode`|=\other
+ \catcode`<=\other
+ \catcode`>=\other
+ \catcode`+=\other
+ \catcode`-=\other
+}
+
+\def\pushthisfilestack{%
+ \expandafter\pushthisfilestackX\popthisfilestack\StackTerm
+}
+\def\pushthisfilestackX{%
+ \expandafter\pushthisfilestackY\thisfile\StackTerm
+}
+\def\pushthisfilestackY #1\StackTerm #2\StackTerm {%
+ \gdef\popthisfilestack{\gdef\thisfile{#1}\gdef\popthisfilestack{#2}}%
+}
+
+\def\popthisfilestack{\errthisfilestackempty}
+\def\errthisfilestackempty{\errmessage{Internal error:
+ the stack of filenames is empty.}}
+
+\def\thisfile{}
+
+% @center line
+% outputs that line, centered.
+%
+\parseargdef\center{%
+ \ifhmode
+ \let\next\centerH
+ \else
+ \let\next\centerV
+ \fi
+ \next{\hfil \ignorespaces#1\unskip \hfil}%
+}
+\def\centerH#1{%
+ {%
+ \hfil\break
+ \advance\hsize by -\leftskip
+ \advance\hsize by -\rightskip
+ \line{#1}%
+ \break
+ }%
+}
+\def\centerV#1{\line{\kern\leftskip #1\kern\rightskip}}
+
+% @sp n outputs n lines of vertical space
+
+\parseargdef\sp{\vskip #1\baselineskip}
+
+% @comment ...line which is ignored...
+% @c is the same as @comment
+% @ignore ... @end ignore is another way to write a comment
+
+\def\comment{\begingroup \catcode`\^^M=\other%
+\catcode`\@=\other \catcode`\{=\other \catcode`\}=\other%
+\commentxxx}
+{\catcode`\^^M=\other \gdef\commentxxx#1^^M{\endgroup}}
+
+\let\c=\comment
+
+% @paragraphindent NCHARS
+% We'll use ems for NCHARS, close enough.
+% NCHARS can also be the word `asis' or `none'.
+% We cannot feasibly implement @paragraphindent asis, though.
+%
+\def\asisword{asis} % no translation, these are keywords
+\def\noneword{none}
+%
+\parseargdef\paragraphindent{%
+ \def\temp{#1}%
+ \ifx\temp\asisword
+ \else
+ \ifx\temp\noneword
+ \defaultparindent = 0pt
+ \else
+ \defaultparindent = #1em
+ \fi
+ \fi
+ \parindent = \defaultparindent
+}
+
+% @exampleindent NCHARS
+% We'll use ems for NCHARS like @paragraphindent.
+% It seems @exampleindent asis isn't necessary, but
+% I preserve it to make it similar to @paragraphindent.
+\parseargdef\exampleindent{%
+ \def\temp{#1}%
+ \ifx\temp\asisword
+ \else
+ \ifx\temp\noneword
+ \lispnarrowing = 0pt
+ \else
+ \lispnarrowing = #1em
+ \fi
+ \fi
+}
+
+% @firstparagraphindent WORD
+% If WORD is `none', then suppress indentation of the first paragraph
+% after a section heading. If WORD is `insert', then do indent at such
+% paragraphs.
+%
+% The paragraph indentation is suppressed or not by calling
+% \suppressfirstparagraphindent, which the sectioning commands do.
+% We switch the definition of this back and forth according to WORD.
+% By default, we suppress indentation.
+%
+\def\suppressfirstparagraphindent{\dosuppressfirstparagraphindent}
+\def\insertword{insert}
+%
+\parseargdef\firstparagraphindent{%
+ \def\temp{#1}%
+ \ifx\temp\noneword
+ \let\suppressfirstparagraphindent = \dosuppressfirstparagraphindent
+ \else\ifx\temp\insertword
+ \let\suppressfirstparagraphindent = \relax
+ \else
+ \errhelp = \EMsimple
+ \errmessage{Unknown @firstparagraphindent option `\temp'}%
+ \fi\fi
+}
+
+% Here is how we actually suppress indentation. Redefine \everypar to
+% \kern backwards by \parindent, and then reset itself to empty.
+%
+% We also make \indent itself not actually do anything until the next
+% paragraph.
+%
+\gdef\dosuppressfirstparagraphindent{%
+ \gdef\indent{%
+ \restorefirstparagraphindent
+ \indent
+ }%
+ \gdef\noindent{%
+ \restorefirstparagraphindent
+ \noindent
+ }%
+ \global\everypar = {%
+ \kern -\parindent
+ \restorefirstparagraphindent
+ }%
+}
+
+\gdef\restorefirstparagraphindent{%
+ \global \let \indent = \ptexindent
+ \global \let \noindent = \ptexnoindent
+ \global \everypar = {}%
+}
+
+
+% @asis just yields its argument. Used with @table, for example.
+%
+\def\asis#1{#1}
+
+% @math outputs its argument in math mode.
+%
+% One complication: _ usually means subscripts, but it could also mean
+% an actual _ character, as in @math{@var{some_variable} + 1}. So make
+% _ active, and distinguish by seeing if the current family is \slfam,
+% which is what @var uses.
+{
+ \catcode`\_ = \active
+ \gdef\mathunderscore{%
+ \catcode`\_=\active
+ \def_{\ifnum\fam=\slfam \_\else\sb\fi}%
+ }
+}
+% Another complication: we want \\ (and @\) to output a \ character.
+% FYI, plain.tex uses \\ as a temporary control sequence (why?), but
+% this is not advertised and we don't care. Texinfo does not
+% otherwise define @\.
+%
+% The \mathchar is class=0=ordinary, family=7=ttfam, position=5C=\.
+\def\mathbackslash{\ifnum\fam=\ttfam \mathchar"075C \else\backslash \fi}
+%
+\def\math{%
+ \tex
+ \mathunderscore
+ \let\\ = \mathbackslash
+ \mathactive
+ $\finishmath
+}
+\def\finishmath#1{#1$\endgroup} % Close the group opened by \tex.
+
+% Some active characters (such as <) are spaced differently in math.
+% We have to reset their definitions in case the @math was an argument
+% to a command which sets the catcodes (such as @item or @section).
+%
+{
+ \catcode`^ = \active
+ \catcode`< = \active
+ \catcode`> = \active
+ \catcode`+ = \active
+ \gdef\mathactive{%
+ \let^ = \ptexhat
+ \let< = \ptexless
+ \let> = \ptexgtr
+ \let+ = \ptexplus
+ }
+}
+
+% @bullet and @minus need the same treatment as @math, just above.
+\def\bullet{$\ptexbullet$}
+\def\minus{$-$}
+
+% @dots{} outputs an ellipsis using the current font.
+% We do .5em per period so that it has the same spacing in the cm
+% typewriter fonts as three actual period characters; on the other hand,
+% in other typewriter fonts three periods are wider than 1.5em. So do
+% whichever is larger.
+%
+\def\dots{%
+ \leavevmode
+ \setbox0=\hbox{...}% get width of three periods
+ \ifdim\wd0 > 1.5em
+ \dimen0 = \wd0
+ \else
+ \dimen0 = 1.5em
+ \fi
+ \hbox to \dimen0{%
+ \hskip 0pt plus.25fil
+ .\hskip 0pt plus1fil
+ .\hskip 0pt plus1fil
+ .\hskip 0pt plus.5fil
+ }%
+}
+
+% @enddots{} is an end-of-sentence ellipsis.
+%
+\def\enddots{%
+ \dots
+ \spacefactor=\endofsentencespacefactor
+}
+
+% @comma{} is so commas can be inserted into text without messing up
+% Texinfo's parsing.
+%
+\let\comma = ,
+
+% @refill is a no-op.
+\let\refill=\relax
+
+% If working on a large document in chapters, it is convenient to
+% be able to disable indexing, cross-referencing, and contents, for test runs.
+% This is done with @novalidate (before @setfilename).
+%
+\newif\iflinks \linkstrue % by default we want the aux files.
+\let\novalidate = \linksfalse
+
+% @setfilename is done at the beginning of every texinfo file.
+% So open here the files we need to have open while reading the input.
+% This makes it possible to make a .fmt file for texinfo.
+\def\setfilename{%
+ \fixbackslash % Turn off hack to swallow `\input texinfo'.
+ \iflinks
+ \tryauxfile
+ % Open the new aux file. TeX will close it automatically at exit.
+ \immediate\openout\auxfile=\jobname.aux
+ \fi % \openindices needs to do some work in any case.
+ \openindices
+ \let\setfilename=\comment % Ignore extra @setfilename cmds.
+ %
+ % If texinfo.cnf is present on the system, read it.
+ % Useful for site-wide @afourpaper, etc.
+ \openin 1 texinfo.cnf
+ \ifeof 1 \else \input texinfo.cnf \fi
+ \closein 1
+ %
+ \comment % Ignore the actual filename.
+}
+
+% Called from \setfilename.
+%
+\def\openindices{%
+ \newindex{cp}%
+ \newcodeindex{fn}%
+ \newcodeindex{vr}%
+ \newcodeindex{tp}%
+ \newcodeindex{ky}%
+ \newcodeindex{pg}%
+}
+
+% @bye.
+\outer\def\bye{\pagealignmacro\tracingstats=1\ptexend}
+
+
+\message{pdf,}
+% adobe `portable' document format
+\newcount\tempnum
+\newcount\lnkcount
+\newtoks\filename
+\newcount\filenamelength
+\newcount\pgn
+\newtoks\toksA
+\newtoks\toksB
+\newtoks\toksC
+\newtoks\toksD
+\newbox\boxA
+\newcount\countA
+\newif\ifpdf
+\newif\ifpdfmakepagedest
+
+% when pdftex is run in dvi mode, \pdfoutput is defined (so \pdfoutput=1
+% can be set). So we test for \relax and 0 as well as \undefined,
+% borrowed from ifpdf.sty.
+\ifx\pdfoutput\undefined
+\else
+ \ifx\pdfoutput\relax
+ \else
+ \ifcase\pdfoutput
+ \else
+ \pdftrue
+ \fi
+ \fi
+\fi
+
+% PDF uses PostScript string constants for the names of xref targets,
+% for display in the outlines, and in other places. Thus, we have to
+% double any backslashes. Otherwise, a name like "\node" will be
+% interpreted as a newline (\n), followed by o, d, e. Not good.
+% http://www.ntg.nl/pipermail/ntg-pdftex/2004-July/000654.html
+% (and related messages, the final outcome is that it is up to the TeX
+% user to double the backslashes and otherwise make the string valid, so
+% that's what we do).
+
+% double active backslashes.
+%
+{\catcode`\@=0 \catcode`\\=\active
+ @gdef@activebackslashdouble{%
+ @catcode`@\=@active
+ @let\=@doublebackslash}
+}
+
+% To handle parens, we must adopt a different approach, since parens are
+% not active characters. hyperref.dtx (which has the same problem as
+% us) handles it with this amazing macro to replace tokens, with minor
+% changes for Texinfo. It is included here under the GPL by permission
+% from the author, Heiko Oberdiek.
+%
+% #1 is the tokens to replace.
+% #2 is the replacement.
+% #3 is the control sequence with the string.
+%
+\def\HyPsdSubst#1#2#3{%
+ \def\HyPsdReplace##1#1##2\END{%
+ ##1%
+ \ifx\\##2\\%
+ \else
+ #2%
+ \HyReturnAfterFi{%
+ \HyPsdReplace##2\END
+ }%
+ \fi
+ }%
+ \xdef#3{\expandafter\HyPsdReplace#3#1\END}%
+}
+\long\def\HyReturnAfterFi#1\fi{\fi#1}
+
+% #1 is a control sequence in which to do the replacements.
+\def\backslashparens#1{%
+ \xdef#1{#1}% redefine it as its expansion; the definition is simply
+ % \lastnode when called from \setref -> \pdfmkdest.
+ \HyPsdSubst{(}{\realbackslash(}{#1}%
+ \HyPsdSubst{)}{\realbackslash)}{#1}%
+}
+
+\newhelp\nopdfimagehelp{Texinfo supports .png, .jpg, .jpeg, and .pdf images
+with PDF output, and none of those formats could be found. (.eps cannot
+be supported due to the design of the PDF format; use regular TeX (DVI
+output) for that.)}
+
+\ifpdf
+ %
+ % Color manipulation macros based on pdfcolor.tex.
+ \def\cmykDarkRed{0.28 1 1 0.35}
+ \def\cmykBlack{0 0 0 1}
+ %
+ \def\pdfsetcolor#1{\pdfliteral{#1 k}}
+ % Set color, and create a mark which defines \thiscolor accordingly,
+ % so that \makeheadline knows which color to restore.
+ \def\setcolor#1{%
+ \xdef\lastcolordefs{\gdef\noexpand\thiscolor{#1}}%
+ \domark
+ \pdfsetcolor{#1}%
+ }
+ %
+ \def\maincolor{\cmykBlack}
+ \pdfsetcolor{\maincolor}
+ \edef\thiscolor{\maincolor}
+ \def\lastcolordefs{}
+ %
+ \def\makefootline{%
+ \baselineskip24pt
+ \line{\pdfsetcolor{\maincolor}\the\footline}%
+ }
+ %
+ \def\makeheadline{%
+ \vbox to 0pt{%
+ \vskip-22.5pt
+ \line{%
+ \vbox to8.5pt{}%
+ % Extract \thiscolor definition from the marks.
+ \getcolormarks
+ % Typeset the headline with \maincolor, then restore the color.
+ \pdfsetcolor{\maincolor}\the\headline\pdfsetcolor{\thiscolor}%
+ }%
+ \vss
+ }%
+ \nointerlineskip
+ }
+ %
+ %
+ \pdfcatalog{/PageMode /UseOutlines}
+ %
+ % #1 is image name, #2 width (might be empty/whitespace), #3 height (ditto).
+ \def\dopdfimage#1#2#3{%
+ \def\imagewidth{#2}\setbox0 = \hbox{\ignorespaces #2}%
+ \def\imageheight{#3}\setbox2 = \hbox{\ignorespaces #3}%
+ %
+ % pdftex (and the PDF format) support .png, .jpg, .pdf (among
+ % others). Let's try in that order.
+ \let\pdfimgext=\empty
+ \begingroup
+ \openin 1 #1.png \ifeof 1
+ \openin 1 #1.jpg \ifeof 1
+ \openin 1 #1.jpeg \ifeof 1
+ \openin 1 #1.JPG \ifeof 1
+ \openin 1 #1.pdf \ifeof 1
+ \errhelp = \nopdfimagehelp
+ \errmessage{Could not find image file #1 for pdf}%
+ \else \gdef\pdfimgext{pdf}%
+ \fi
+ \else \gdef\pdfimgext{JPG}%
+ \fi
+ \else \gdef\pdfimgext{jpeg}%
+ \fi
+ \else \gdef\pdfimgext{jpg}%
+ \fi
+ \else \gdef\pdfimgext{png}%
+ \fi
+ \closein 1
+ \endgroup
+ %
+ % without \immediate, pdftex seg faults when the same image is
+ % included twice. (Version 3.14159-pre-1.0-unofficial-20010704.)
+ \ifnum\pdftexversion < 14
+ \immediate\pdfimage
+ \else
+ \immediate\pdfximage
+ \fi
+ \ifdim \wd0 >0pt width \imagewidth \fi
+ \ifdim \wd2 >0pt height \imageheight \fi
+ \ifnum\pdftexversion<13
+ #1.\pdfimgext
+ \else
+ {#1.\pdfimgext}%
+ \fi
+ \ifnum\pdftexversion < 14 \else
+ \pdfrefximage \pdflastximage
+ \fi}
+ %
+ \def\pdfmkdest#1{{%
+ % We have to set dummies so commands such as @code, and characters
+ % such as \, aren't expanded when present in a section title.
+ \indexnofonts
+ \turnoffactive
+ \activebackslashdouble
+ \makevalueexpandable
+ \def\pdfdestname{#1}%
+ \backslashparens\pdfdestname
+ \safewhatsit{\pdfdest name{\pdfdestname} xyz}%
+ }}
+ %
+ % used to mark target names; must be expandable.
+ \def\pdfmkpgn#1{#1}
+ %
+ % by default, use a color that is dark enough to print on paper as
+ % nearly black, but still distinguishable for online viewing.
+ \def\urlcolor{\cmykDarkRed}
+ \def\linkcolor{\cmykDarkRed}
+ \def\endlink{\setcolor{\maincolor}\pdfendlink}
+ %
+ % Adding outlines to PDF; macros for calculating structure of outlines
+ % come from Petr Olsak
+ \def\expnumber#1{\expandafter\ifx\csname#1\endcsname\relax 0%
+ \else \csname#1\endcsname \fi}
+ \def\advancenumber#1{\tempnum=\expnumber{#1}\relax
+ \advance\tempnum by 1
+ \expandafter\xdef\csname#1\endcsname{\the\tempnum}}
+ %
+ % #1 is the section text, which is what will be displayed in the
+ % outline by the pdf viewer. #2 is the pdf expression for the number
+ % of subentries (or empty, for subsubsections). #3 is the node text,
+ % which might be empty if this toc entry had no corresponding node.
+ % #4 is the page number
+ %
+ \def\dopdfoutline#1#2#3#4{%
+ % Generate a link to the node text if that exists; else, use the
+ % page number. We could generate a destination for the section
+ % text in the case where a section has no node, but it doesn't
+ % seem worth the trouble, since most documents are normally structured.
+ \def\pdfoutlinedest{#3}%
+ \ifx\pdfoutlinedest\empty
+ \def\pdfoutlinedest{#4}%
+ \else
+ % Doubled backslashes in the name.
+ {\activebackslashdouble \xdef\pdfoutlinedest{#3}%
+ \backslashparens\pdfoutlinedest}%
+ \fi
+ %
+ % Also double the backslashes in the display string.
+ {\activebackslashdouble \xdef\pdfoutlinetext{#1}%
+ \backslashparens\pdfoutlinetext}%
+ %
+ \pdfoutline goto name{\pdfmkpgn{\pdfoutlinedest}}#2{\pdfoutlinetext}%
+ }
+ %
+ \def\pdfmakeoutlines{%
+ \begingroup
+ % Thanh's hack / proper braces in bookmarks
+ \edef\mylbrace{\iftrue \string{\else}\fi}\let\{=\mylbrace
+ \edef\myrbrace{\iffalse{\else\string}\fi}\let\}=\myrbrace
+ %
+ % Read toc silently, to get counts of subentries for \pdfoutline.
+ \def\numchapentry##1##2##3##4{%
+ \def\thischapnum{##2}%
+ \def\thissecnum{0}%
+ \def\thissubsecnum{0}%
+ }%
+ \def\numsecentry##1##2##3##4{%
+ \advancenumber{chap\thischapnum}%
+ \def\thissecnum{##2}%
+ \def\thissubsecnum{0}%
+ }%
+ \def\numsubsecentry##1##2##3##4{%
+ \advancenumber{sec\thissecnum}%
+ \def\thissubsecnum{##2}%
+ }%
+ \def\numsubsubsecentry##1##2##3##4{%
+ \advancenumber{subsec\thissubsecnum}%
+ }%
+ \def\thischapnum{0}%
+ \def\thissecnum{0}%
+ \def\thissubsecnum{0}%
+ %
+ % use \def rather than \let here because we redefine \chapentry et
+ % al. a second time, below.
+ \def\appentry{\numchapentry}%
+ \def\appsecentry{\numsecentry}%
+ \def\appsubsecentry{\numsubsecentry}%
+ \def\appsubsubsecentry{\numsubsubsecentry}%
+ \def\unnchapentry{\numchapentry}%
+ \def\unnsecentry{\numsecentry}%
+ \def\unnsubsecentry{\numsubsecentry}%
+ \def\unnsubsubsecentry{\numsubsubsecentry}%
+ \readdatafile{toc}%
+ %
+ % Read toc second time, this time actually producing the outlines.
+ % The `-' means take the \expnumber as the absolute number of
+ % subentries, which we calculated on our first read of the .toc above.
+ %
+ % We use the node names as the destinations.
+ \def\numchapentry##1##2##3##4{%
+ \dopdfoutline{##1}{count-\expnumber{chap##2}}{##3}{##4}}%
+ \def\numsecentry##1##2##3##4{%
+ \dopdfoutline{##1}{count-\expnumber{sec##2}}{##3}{##4}}%
+ \def\numsubsecentry##1##2##3##4{%
+ \dopdfoutline{##1}{count-\expnumber{subsec##2}}{##3}{##4}}%
+ \def\numsubsubsecentry##1##2##3##4{% count is always zero
+ \dopdfoutline{##1}{}{##3}{##4}}%
+ %
+ % PDF outlines are displayed using system fonts, instead of
+ % document fonts. Therefore we cannot use special characters,
+ % since the encoding is unknown. For example, the eogonek from
+ % Latin 2 (0xea) gets translated to a | character. Info from
+ % Staszek Wawrykiewicz, 19 Jan 2004 04:09:24 +0100.
+ %
+ % xx to do this right, we have to translate 8-bit characters to
+ % their "best" equivalent, based on the @documentencoding. Right
+ % now, I guess we'll just let the pdf reader have its way.
+ \indexnofonts
+ \setupdatafile
+ \catcode`\\=\active \otherbackslash
+ \input \tocreadfilename
+ \endgroup
+ }
+ %
+ \def\skipspaces#1{\def\PP{#1}\def\D{|}%
+ \ifx\PP\D\let\nextsp\relax
+ \else\let\nextsp\skipspaces
+ \ifx\p\space\else\addtokens{\filename}{\PP}%
+ \advance\filenamelength by 1
+ \fi
+ \fi
+ \nextsp}
+ \def\getfilename#1{\filenamelength=0\expandafter\skipspaces#1|\relax}
+ \ifnum\pdftexversion < 14
+ \let \startlink \pdfannotlink
+ \else
+ \let \startlink \pdfstartlink
+ \fi
+ % make a live url in pdf output.
+ \def\pdfurl#1{%
+ \begingroup
+ % it seems we really need yet another set of dummies; have not
+ % tried to figure out what each command should do in the context
+ % of @url. for now, just make @/ a no-op, that's the only one
+ % people have actually reported a problem with.
+ %
+ \normalturnoffactive
+ \def\@{@}%
+ \let\/=\empty
+ \makevalueexpandable
+ \leavevmode\setcolor{\urlcolor}%
+ \startlink attr{/Border [0 0 0]}%
+ user{/Subtype /Link /A << /S /URI /URI (#1) >>}%
+ \endgroup}
+ \def\pdfgettoks#1.{\setbox\boxA=\hbox{\toksA={#1.}\toksB={}\maketoks}}
+ \def\addtokens#1#2{\edef\addtoks{\noexpand#1={\the#1#2}}\addtoks}
+ \def\adn#1{\addtokens{\toksC}{#1}\global\countA=1\let\next=\maketoks}
+ \def\poptoks#1#2|ENDTOKS|{\let\first=#1\toksD={#1}\toksA={#2}}
+ \def\maketoks{%
+ \expandafter\poptoks\the\toksA|ENDTOKS|\relax
+ \ifx\first0\adn0
+ \else\ifx\first1\adn1 \else\ifx\first2\adn2 \else\ifx\first3\adn3
+ \else\ifx\first4\adn4 \else\ifx\first5\adn5 \else\ifx\first6\adn6
+ \else\ifx\first7\adn7 \else\ifx\first8\adn8 \else\ifx\first9\adn9
+ \else
+ \ifnum0=\countA\else\makelink\fi
+ \ifx\first.\let\next=\done\else
+ \let\next=\maketoks
+ \addtokens{\toksB}{\the\toksD}
+ \ifx\first,\addtokens{\toksB}{\space}\fi
+ \fi
+ \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi
+ \next}
+ \def\makelink{\addtokens{\toksB}%
+ {\noexpand\pdflink{\the\toksC}}\toksC={}\global\countA=0}
+ \def\pdflink#1{%
+ \startlink attr{/Border [0 0 0]} goto name{\pdfmkpgn{#1}}
+ \setcolor{\linkcolor}#1\endlink}
+ \def\done{\edef\st{\global\noexpand\toksA={\the\toksB}}\st}
+\else
+ \let\pdfmkdest = \gobble
+ \let\pdfurl = \gobble
+ \let\endlink = \relax
+ \let\setcolor = \gobble
+ \let\pdfsetcolor = \gobble
+ \let\pdfmakeoutlines = \relax
+\fi % \ifx\pdfoutput
+
+
+\message{fonts,}
+
+% Change the current font style to #1, remembering it in \curfontstyle.
+% For now, we do not accumulate font styles: @b{@i{foo}} prints foo in
+% italics, not bold italics.
+%
+\def\setfontstyle#1{%
+ \def\curfontstyle{#1}% not as a control sequence, because we are \edef'd.
+ \csname ten#1\endcsname % change the current font
+}
+
+% Select #1 fonts with the current style.
+%
+\def\selectfonts#1{\csname #1fonts\endcsname \csname\curfontstyle\endcsname}
+
+\def\rm{\fam=0 \setfontstyle{rm}}
+\def\it{\fam=\itfam \setfontstyle{it}}
+\def\sl{\fam=\slfam \setfontstyle{sl}}
+\def\bf{\fam=\bffam \setfontstyle{bf}}\def\bfstylename{bf}
+\def\tt{\fam=\ttfam \setfontstyle{tt}}
+
+% Texinfo sort of supports the sans serif font style, which plain TeX does not.
+% So we set up a \sf.
+\newfam\sffam
+\def\sf{\fam=\sffam \setfontstyle{sf}}
+\let\li = \sf % Sometimes we call it \li, not \sf.
+
+% We don't need math for this font style.
+\def\ttsl{\setfontstyle{ttsl}}
+
+
+% Default leading.
+\newdimen\textleading \textleading = 13.2pt
+
+% Set the baselineskip to #1, and the lineskip and strut size
+% correspondingly. There is no deep meaning behind these magic numbers
+% used as factors; they just match (closely enough) what Knuth defined.
+%
+\def\lineskipfactor{.08333}
+\def\strutheightpercent{.70833}
+\def\strutdepthpercent {.29167}
+%
+% can get a sort of poor man's double spacing by redefining this.
+\def\baselinefactor{1}
+%
+\def\setleading#1{%
+ \dimen0 = #1\relax
+ \normalbaselineskip = \baselinefactor\dimen0
+ \normallineskip = \lineskipfactor\normalbaselineskip
+ \normalbaselines
+ \setbox\strutbox =\hbox{%
+ \vrule width0pt height\strutheightpercent\baselineskip
+ depth \strutdepthpercent \baselineskip
+ }%
+}
+
+% PDF CMaps. See also LaTeX's t1.cmap.
+%
+% do nothing with this by default.
+\expandafter\let\csname cmapOT1\endcsname\gobble
+\expandafter\let\csname cmapOT1IT\endcsname\gobble
+\expandafter\let\csname cmapOT1TT\endcsname\gobble
+
+% if we are producing pdf, and we have \pdffontattr, then define cmaps.
+% (\pdffontattr was introduced many years ago, but people still run
+% older pdftex's; it's easy to conditionalize, so we do.)
+\ifpdf \ifx\pdffontattr\undefined \else
+ \begingroup
+ \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char.
+ \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap
+%%DocumentNeededResources: ProcSet (CIDInit)
+%%IncludeResource: ProcSet (CIDInit)
+%%BeginResource: CMap (TeX-OT1-0)
+%%Title: (TeX-OT1-0 TeX OT1 0)
+%%Version: 1.000
+%%EndComments
+/CIDInit /ProcSet findresource begin
+12 dict begin
+begincmap
+/CIDSystemInfo
+<< /Registry (TeX)
+/Ordering (OT1)
+/Supplement 0
+>> def
+/CMapName /TeX-OT1-0 def
+/CMapType 2 def
+1 begincodespacerange
+<00> <7F>
+endcodespacerange
+8 beginbfrange
+<00> <01> <0393>
+<09> <0A> <03A8>
+<23> <26> <0023>
+<28> <3B> <0028>
+<3F> <5B> <003F>
+<5D> <5E> <005D>
+<61> <7A> <0061>
+<7B> <7C> <2013>
+endbfrange
+40 beginbfchar
+<02> <0398>
+<03> <039B>
+<04> <039E>
+<05> <03A0>
+<06> <03A3>
+<07> <03D2>
+<08> <03A6>
+<0B> <00660066>
+<0C> <00660069>
+<0D> <0066006C>
+<0E> <006600660069>
+<0F> <00660066006C>
+<10> <0131>
+<11> <0237>
+<12> <0060>
+<13> <00B4>
+<14> <02C7>
+<15> <02D8>
+<16> <00AF>
+<17> <02DA>
+<18> <00B8>
+<19> <00DF>
+<1A> <00E6>
+<1B> <0153>
+<1C> <00F8>
+<1D> <00C6>
+<1E> <0152>
+<1F> <00D8>
+<21> <0021>
+<22> <201D>
+<27> <2019>
+<3C> <00A1>
+<3D> <003D>
+<3E> <00BF>
+<5C> <201C>
+<5F> <02D9>
+<60> <2018>
+<7D> <02DD>
+<7E> <007E>
+<7F> <00A8>
+endbfchar
+endcmap
+CMapName currentdict /CMap defineresource pop
+end
+end
+%%EndResource
+%%EOF
+ }\endgroup
+ \expandafter\edef\csname cmapOT1\endcsname#1{%
+ \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}%
+ }%
+%
+% \cmapOT1IT
+ \begingroup
+ \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char.
+ \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap
+%%DocumentNeededResources: ProcSet (CIDInit)
+%%IncludeResource: ProcSet (CIDInit)
+%%BeginResource: CMap (TeX-OT1IT-0)
+%%Title: (TeX-OT1IT-0 TeX OT1IT 0)
+%%Version: 1.000
+%%EndComments
+/CIDInit /ProcSet findresource begin
+12 dict begin
+begincmap
+/CIDSystemInfo
+<< /Registry (TeX)
+/Ordering (OT1IT)
+/Supplement 0
+>> def
+/CMapName /TeX-OT1IT-0 def
+/CMapType 2 def
+1 begincodespacerange
+<00> <7F>
+endcodespacerange
+8 beginbfrange
+<00> <01> <0393>
+<09> <0A> <03A8>
+<25> <26> <0025>
+<28> <3B> <0028>
+<3F> <5B> <003F>
+<5D> <5E> <005D>
+<61> <7A> <0061>
+<7B> <7C> <2013>
+endbfrange
+42 beginbfchar
+<02> <0398>
+<03> <039B>
+<04> <039E>
+<05> <03A0>
+<06> <03A3>
+<07> <03D2>
+<08> <03A6>
+<0B> <00660066>
+<0C> <00660069>
+<0D> <0066006C>
+<0E> <006600660069>
+<0F> <00660066006C>
+<10> <0131>
+<11> <0237>
+<12> <0060>
+<13> <00B4>
+<14> <02C7>
+<15> <02D8>
+<16> <00AF>
+<17> <02DA>
+<18> <00B8>
+<19> <00DF>
+<1A> <00E6>
+<1B> <0153>
+<1C> <00F8>
+<1D> <00C6>
+<1E> <0152>
+<1F> <00D8>
+<21> <0021>
+<22> <201D>
+<23> <0023>
+<24> <00A3>
+<27> <2019>
+<3C> <00A1>
+<3D> <003D>
+<3E> <00BF>
+<5C> <201C>
+<5F> <02D9>
+<60> <2018>
+<7D> <02DD>
+<7E> <007E>
+<7F> <00A8>
+endbfchar
+endcmap
+CMapName currentdict /CMap defineresource pop
+end
+end
+%%EndResource
+%%EOF
+ }\endgroup
+ \expandafter\edef\csname cmapOT1IT\endcsname#1{%
+ \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}%
+ }%
+%
+% \cmapOT1TT
+ \begingroup
+ \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char.
+ \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap
+%%DocumentNeededResources: ProcSet (CIDInit)
+%%IncludeResource: ProcSet (CIDInit)
+%%BeginResource: CMap (TeX-OT1TT-0)
+%%Title: (TeX-OT1TT-0 TeX OT1TT 0)
+%%Version: 1.000
+%%EndComments
+/CIDInit /ProcSet findresource begin
+12 dict begin
+begincmap
+/CIDSystemInfo
+<< /Registry (TeX)
+/Ordering (OT1TT)
+/Supplement 0
+>> def
+/CMapName /TeX-OT1TT-0 def
+/CMapType 2 def
+1 begincodespacerange
+<00> <7F>
+endcodespacerange
+5 beginbfrange
+<00> <01> <0393>
+<09> <0A> <03A8>
+<21> <26> <0021>
+<28> <5F> <0028>
+<61> <7E> <0061>
+endbfrange
+32 beginbfchar
+<02> <0398>
+<03> <039B>
+<04> <039E>
+<05> <03A0>
+<06> <03A3>
+<07> <03D2>
+<08> <03A6>
+<0B> <2191>
+<0C> <2193>
+<0D> <0027>
+<0E> <00A1>
+<0F> <00BF>
+<10> <0131>
+<11> <0237>
+<12> <0060>
+<13> <00B4>
+<14> <02C7>
+<15> <02D8>
+<16> <00AF>
+<17> <02DA>
+<18> <00B8>
+<19> <00DF>
+<1A> <00E6>
+<1B> <0153>
+<1C> <00F8>
+<1D> <00C6>
+<1E> <0152>
+<1F> <00D8>
+<20> <2423>
+<27> <2019>
+<60> <2018>
+<7F> <00A8>
+endbfchar
+endcmap
+CMapName currentdict /CMap defineresource pop
+end
+end
+%%EndResource
+%%EOF
+ }\endgroup
+ \expandafter\edef\csname cmapOT1TT\endcsname#1{%
+ \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}%
+ }%
+\fi\fi
+
+
+% Set the font macro #1 to the font named #2, adding on the
+% specified font prefix (normally `cm').
+% #3 is the font's design size, #4 is a scale factor, #5 is the CMap
+% encoding (currently only OT1, OT1IT and OT1TT are allowed, pass
+% empty to omit).
+\def\setfont#1#2#3#4#5{%
+ \font#1=\fontprefix#2#3 scaled #4
+ \csname cmap#5\endcsname#1%
+}
+% This is what gets called when #5 of \setfont is empty.
+\let\cmap\gobble
+% emacs-page end of cmaps
+
+% Use cm as the default font prefix.
+% To specify the font prefix, you must define \fontprefix
+% before you read in texinfo.tex.
+\ifx\fontprefix\undefined
+\def\fontprefix{cm}
+\fi
+% Support font families that don't use the same naming scheme as CM.
+\def\rmshape{r}
+\def\rmbshape{bx} %where the normal face is bold
+\def\bfshape{b}
+\def\bxshape{bx}
+\def\ttshape{tt}
+\def\ttbshape{tt}
+\def\ttslshape{sltt}
+\def\itshape{ti}
+\def\itbshape{bxti}
+\def\slshape{sl}
+\def\slbshape{bxsl}
+\def\sfshape{ss}
+\def\sfbshape{ss}
+\def\scshape{csc}
+\def\scbshape{csc}
+
+% Definitions for a main text size of 11pt. This is the default in
+% Texinfo.
+%
+\def\definetextfontsizexi{%
+% Text fonts (11.2pt, magstep1).
+\def\textnominalsize{11pt}
+\edef\mainmagstep{\magstephalf}
+\setfont\textrm\rmshape{10}{\mainmagstep}{OT1}
+\setfont\texttt\ttshape{10}{\mainmagstep}{OT1TT}
+\setfont\textbf\bfshape{10}{\mainmagstep}{OT1}
+\setfont\textit\itshape{10}{\mainmagstep}{OT1IT}
+\setfont\textsl\slshape{10}{\mainmagstep}{OT1}
+\setfont\textsf\sfshape{10}{\mainmagstep}{OT1}
+\setfont\textsc\scshape{10}{\mainmagstep}{OT1}
+\setfont\textttsl\ttslshape{10}{\mainmagstep}{OT1TT}
+\font\texti=cmmi10 scaled \mainmagstep
+\font\textsy=cmsy10 scaled \mainmagstep
+\def\textecsize{1095}
+
+% A few fonts for @defun names and args.
+\setfont\defbf\bfshape{10}{\magstep1}{OT1}
+\setfont\deftt\ttshape{10}{\magstep1}{OT1TT}
+\setfont\defttsl\ttslshape{10}{\magstep1}{OT1TT}
+\def\df{\let\tentt=\deftt \let\tenbf = \defbf \let\tenttsl=\defttsl \bf}
+
+% Fonts for indices, footnotes, small examples (9pt).
+\def\smallnominalsize{9pt}
+\setfont\smallrm\rmshape{9}{1000}{OT1}
+\setfont\smalltt\ttshape{9}{1000}{OT1TT}
+\setfont\smallbf\bfshape{10}{900}{OT1}
+\setfont\smallit\itshape{9}{1000}{OT1IT}
+\setfont\smallsl\slshape{9}{1000}{OT1}
+\setfont\smallsf\sfshape{9}{1000}{OT1}
+\setfont\smallsc\scshape{10}{900}{OT1}
+\setfont\smallttsl\ttslshape{10}{900}{OT1TT}
+\font\smalli=cmmi9
+\font\smallsy=cmsy9
+\def\smallecsize{0900}
+
+% Fonts for small examples (8pt).
+\def\smallernominalsize{8pt}
+\setfont\smallerrm\rmshape{8}{1000}{OT1}
+\setfont\smallertt\ttshape{8}{1000}{OT1TT}
+\setfont\smallerbf\bfshape{10}{800}{OT1}
+\setfont\smallerit\itshape{8}{1000}{OT1IT}
+\setfont\smallersl\slshape{8}{1000}{OT1}
+\setfont\smallersf\sfshape{8}{1000}{OT1}
+\setfont\smallersc\scshape{10}{800}{OT1}
+\setfont\smallerttsl\ttslshape{10}{800}{OT1TT}
+\font\smalleri=cmmi8
+\font\smallersy=cmsy8
+\def\smallerecsize{0800}
+
+% Fonts for title page (20.4pt):
+\def\titlenominalsize{20pt}
+\setfont\titlerm\rmbshape{12}{\magstep3}{OT1}
+\setfont\titleit\itbshape{10}{\magstep4}{OT1IT}
+\setfont\titlesl\slbshape{10}{\magstep4}{OT1}
+\setfont\titlett\ttbshape{12}{\magstep3}{OT1TT}
+\setfont\titlettsl\ttslshape{10}{\magstep4}{OT1TT}
+\setfont\titlesf\sfbshape{17}{\magstep1}{OT1}
+\let\titlebf=\titlerm
+\setfont\titlesc\scbshape{10}{\magstep4}{OT1}
+\font\titlei=cmmi12 scaled \magstep3
+\font\titlesy=cmsy10 scaled \magstep4
+\def\authorrm{\secrm}
+\def\authortt{\sectt}
+\def\titleecsize{2074}
+
+% Chapter (and unnumbered) fonts (17.28pt).
+\def\chapnominalsize{17pt}
+\setfont\chaprm\rmbshape{12}{\magstep2}{OT1}
+\setfont\chapit\itbshape{10}{\magstep3}{OT1IT}
+\setfont\chapsl\slbshape{10}{\magstep3}{OT1}
+\setfont\chaptt\ttbshape{12}{\magstep2}{OT1TT}
+\setfont\chapttsl\ttslshape{10}{\magstep3}{OT1TT}
+\setfont\chapsf\sfbshape{17}{1000}{OT1}
+\let\chapbf=\chaprm
+\setfont\chapsc\scbshape{10}{\magstep3}{OT1}
+\font\chapi=cmmi12 scaled \magstep2
+\font\chapsy=cmsy10 scaled \magstep3
+\def\chapecsize{1728}
+
+% Section fonts (14.4pt).
+\def\secnominalsize{14pt}
+\setfont\secrm\rmbshape{12}{\magstep1}{OT1}
+\setfont\secit\itbshape{10}{\magstep2}{OT1IT}
+\setfont\secsl\slbshape{10}{\magstep2}{OT1}
+\setfont\sectt\ttbshape{12}{\magstep1}{OT1TT}
+\setfont\secttsl\ttslshape{10}{\magstep2}{OT1TT}
+\setfont\secsf\sfbshape{12}{\magstep1}{OT1}
+\let\secbf\secrm
+\setfont\secsc\scbshape{10}{\magstep2}{OT1}
+\font\seci=cmmi12 scaled \magstep1
+\font\secsy=cmsy10 scaled \magstep2
+\def\sececsize{1440}
+
+% Subsection fonts (13.15pt).
+\def\ssecnominalsize{13pt}
+\setfont\ssecrm\rmbshape{12}{\magstephalf}{OT1}
+\setfont\ssecit\itbshape{10}{1315}{OT1IT}
+\setfont\ssecsl\slbshape{10}{1315}{OT1}
+\setfont\ssectt\ttbshape{12}{\magstephalf}{OT1TT}
+\setfont\ssecttsl\ttslshape{10}{1315}{OT1TT}
+\setfont\ssecsf\sfbshape{12}{\magstephalf}{OT1}
+\let\ssecbf\ssecrm
+\setfont\ssecsc\scbshape{10}{1315}{OT1}
+\font\sseci=cmmi12 scaled \magstephalf
+\font\ssecsy=cmsy10 scaled 1315
+\def\ssececsize{1200}
+
+% Reduced fonts for @acro in text (10pt).
+\def\reducednominalsize{10pt}
+\setfont\reducedrm\rmshape{10}{1000}{OT1}
+\setfont\reducedtt\ttshape{10}{1000}{OT1TT}
+\setfont\reducedbf\bfshape{10}{1000}{OT1}
+\setfont\reducedit\itshape{10}{1000}{OT1IT}
+\setfont\reducedsl\slshape{10}{1000}{OT1}
+\setfont\reducedsf\sfshape{10}{1000}{OT1}
+\setfont\reducedsc\scshape{10}{1000}{OT1}
+\setfont\reducedttsl\ttslshape{10}{1000}{OT1TT}
+\font\reducedi=cmmi10
+\font\reducedsy=cmsy10
+\def\reducedecsize{1000}
+
+% reset the current fonts
+\textfonts
+\rm
+} % end of 11pt text font size definitions
+
+
+% Definitions to make the main text be 10pt Computer Modern, with
+% section, chapter, etc., sizes following suit. This is for the GNU
+% Press printing of the Emacs 22 manual. Maybe other manuals in the
+% future. Used with @smallbook, which sets the leading to 12pt.
+%
+\def\definetextfontsizex{%
+% Text fonts (10pt).
+\def\textnominalsize{10pt}
+\edef\mainmagstep{1000}
+\setfont\textrm\rmshape{10}{\mainmagstep}{OT1}
+\setfont\texttt\ttshape{10}{\mainmagstep}{OT1TT}
+\setfont\textbf\bfshape{10}{\mainmagstep}{OT1}
+\setfont\textit\itshape{10}{\mainmagstep}{OT1IT}
+\setfont\textsl\slshape{10}{\mainmagstep}{OT1}
+\setfont\textsf\sfshape{10}{\mainmagstep}{OT1}
+\setfont\textsc\scshape{10}{\mainmagstep}{OT1}
+\setfont\textttsl\ttslshape{10}{\mainmagstep}{OT1TT}
+\font\texti=cmmi10 scaled \mainmagstep
+\font\textsy=cmsy10 scaled \mainmagstep
+\def\textecsize{1000}
+
+% A few fonts for @defun names and args.
+\setfont\defbf\bfshape{10}{\magstephalf}{OT1}
+\setfont\deftt\ttshape{10}{\magstephalf}{OT1TT}
+\setfont\defttsl\ttslshape{10}{\magstephalf}{OT1TT}
+\def\df{\let\tentt=\deftt \let\tenbf = \defbf \let\tenttsl=\defttsl \bf}
+
+% Fonts for indices, footnotes, small examples (9pt).
+\def\smallnominalsize{9pt}
+\setfont\smallrm\rmshape{9}{1000}{OT1}
+\setfont\smalltt\ttshape{9}{1000}{OT1TT}
+\setfont\smallbf\bfshape{10}{900}{OT1}
+\setfont\smallit\itshape{9}{1000}{OT1IT}
+\setfont\smallsl\slshape{9}{1000}{OT1}
+\setfont\smallsf\sfshape{9}{1000}{OT1}
+\setfont\smallsc\scshape{10}{900}{OT1}
+\setfont\smallttsl\ttslshape{10}{900}{OT1TT}
+\font\smalli=cmmi9
+\font\smallsy=cmsy9
+\def\smallecsize{0900}
+
+% Fonts for small examples (8pt).
+\def\smallernominalsize{8pt}
+\setfont\smallerrm\rmshape{8}{1000}{OT1}
+\setfont\smallertt\ttshape{8}{1000}{OT1TT}
+\setfont\smallerbf\bfshape{10}{800}{OT1}
+\setfont\smallerit\itshape{8}{1000}{OT1IT}
+\setfont\smallersl\slshape{8}{1000}{OT1}
+\setfont\smallersf\sfshape{8}{1000}{OT1}
+\setfont\smallersc\scshape{10}{800}{OT1}
+\setfont\smallerttsl\ttslshape{10}{800}{OT1TT}
+\font\smalleri=cmmi8
+\font\smallersy=cmsy8
+\def\smallerecsize{0800}
+
+% Fonts for title page (20.4pt):
+\def\titlenominalsize{20pt}
+\setfont\titlerm\rmbshape{12}{\magstep3}{OT1}
+\setfont\titleit\itbshape{10}{\magstep4}{OT1IT}
+\setfont\titlesl\slbshape{10}{\magstep4}{OT1}
+\setfont\titlett\ttbshape{12}{\magstep3}{OT1TT}
+\setfont\titlettsl\ttslshape{10}{\magstep4}{OT1TT}
+\setfont\titlesf\sfbshape{17}{\magstep1}{OT1}
+\let\titlebf=\titlerm
+\setfont\titlesc\scbshape{10}{\magstep4}{OT1}
+\font\titlei=cmmi12 scaled \magstep3
+\font\titlesy=cmsy10 scaled \magstep4
+\def\authorrm{\secrm}
+\def\authortt{\sectt}
+\def\titleecsize{2074}
+
+% Chapter fonts (14.4pt).
+\def\chapnominalsize{14pt}
+\setfont\chaprm\rmbshape{12}{\magstep1}{OT1}
+\setfont\chapit\itbshape{10}{\magstep2}{OT1IT}
+\setfont\chapsl\slbshape{10}{\magstep2}{OT1}
+\setfont\chaptt\ttbshape{12}{\magstep1}{OT1TT}
+\setfont\chapttsl\ttslshape{10}{\magstep2}{OT1TT}
+\setfont\chapsf\sfbshape{12}{\magstep1}{OT1}
+\let\chapbf\chaprm
+\setfont\chapsc\scbshape{10}{\magstep2}{OT1}
+\font\chapi=cmmi12 scaled \magstep1
+\font\chapsy=cmsy10 scaled \magstep2
+\def\chapecsize{1440}
+
+% Section fonts (12pt).
+\def\secnominalsize{12pt}
+\setfont\secrm\rmbshape{12}{1000}{OT1}
+\setfont\secit\itbshape{10}{\magstep1}{OT1IT}
+\setfont\secsl\slbshape{10}{\magstep1}{OT1}
+\setfont\sectt\ttbshape{12}{1000}{OT1TT}
+\setfont\secttsl\ttslshape{10}{\magstep1}{OT1TT}
+\setfont\secsf\sfbshape{12}{1000}{OT1}
+\let\secbf\secrm
+\setfont\secsc\scbshape{10}{\magstep1}{OT1}
+\font\seci=cmmi12
+\font\secsy=cmsy10 scaled \magstep1
+\def\sececsize{1200}
+
+% Subsection fonts (10pt).
+\def\ssecnominalsize{10pt}
+\setfont\ssecrm\rmbshape{10}{1000}{OT1}
+\setfont\ssecit\itbshape{10}{1000}{OT1IT}
+\setfont\ssecsl\slbshape{10}{1000}{OT1}
+\setfont\ssectt\ttbshape{10}{1000}{OT1TT}
+\setfont\ssecttsl\ttslshape{10}{1000}{OT1TT}
+\setfont\ssecsf\sfbshape{10}{1000}{OT1}
+\let\ssecbf\ssecrm
+\setfont\ssecsc\scbshape{10}{1000}{OT1}
+\font\sseci=cmmi10
+\font\ssecsy=cmsy10
+\def\ssececsize{1000}
+
+% Reduced fonts for @acro in text (9pt).
+\def\reducednominalsize{9pt}
+\setfont\reducedrm\rmshape{9}{1000}{OT1}
+\setfont\reducedtt\ttshape{9}{1000}{OT1TT}
+\setfont\reducedbf\bfshape{10}{900}{OT1}
+\setfont\reducedit\itshape{9}{1000}{OT1IT}
+\setfont\reducedsl\slshape{9}{1000}{OT1}
+\setfont\reducedsf\sfshape{9}{1000}{OT1}
+\setfont\reducedsc\scshape{10}{900}{OT1}
+\setfont\reducedttsl\ttslshape{10}{900}{OT1TT}
+\font\reducedi=cmmi9
+\font\reducedsy=cmsy9
+\def\reducedecsize{0900}
+
+% reduce space between paragraphs
+\divide\parskip by 2
+
+% reset the current fonts
+\textfonts
+\rm
+} % end of 10pt text font size definitions
+
+
+% We provide the user-level command
+% @fonttextsize 10
+% (or 11) to redefine the text font size. pt is assumed.
+%
+\def\xword{10}
+\def\xiword{11}
+%
+\parseargdef\fonttextsize{%
+ \def\textsizearg{#1}%
+ \wlog{doing @fonttextsize \textsizearg}%
+ %
+ % Set \globaldefs so that documents can use this inside @tex, since
+ % makeinfo 4.8 does not support it, but we need it nonetheless.
+ %
+ \begingroup \globaldefs=1
+ \ifx\textsizearg\xword \definetextfontsizex
+ \else \ifx\textsizearg\xiword \definetextfontsizexi
+ \else
+ \errhelp=\EMsimple
+ \errmessage{@fonttextsize only supports `10' or `11', not `\textsizearg'}
+ \fi\fi
+ \endgroup
+}
+
+
+% In order for the font changes to affect most math symbols and letters,
+% we have to define the \textfont of the standard families. Since
+% texinfo doesn't allow for producing subscripts and superscripts except
+% in the main text, we don't bother to reset \scriptfont and
+% \scriptscriptfont (which would also require loading a lot more fonts).
+%
+\def\resetmathfonts{%
+ \textfont0=\tenrm \textfont1=\teni \textfont2=\tensy
+ \textfont\itfam=\tenit \textfont\slfam=\tensl \textfont\bffam=\tenbf
+ \textfont\ttfam=\tentt \textfont\sffam=\tensf
+}
+
+% The font-changing commands redefine the meanings of \tenSTYLE, instead
+% of just \STYLE. We do this because \STYLE needs to also set the
+% current \fam for math mode. Our \STYLE (e.g., \rm) commands hardwire
+% \tenSTYLE to set the current font.
+%
+% Each font-changing command also sets the names \lsize (one size lower)
+% and \lllsize (three sizes lower). These relative commands are used in
+% the LaTeX logo and acronyms.
+%
+% This all needs generalizing, badly.
+%
+\def\textfonts{%
+ \let\tenrm=\textrm \let\tenit=\textit \let\tensl=\textsl
+ \let\tenbf=\textbf \let\tentt=\texttt \let\smallcaps=\textsc
+ \let\tensf=\textsf \let\teni=\texti \let\tensy=\textsy
+ \let\tenttsl=\textttsl
+ \def\curfontsize{text}%
+ \def\lsize{reduced}\def\lllsize{smaller}%
+ \resetmathfonts \setleading{\textleading}}
+\def\titlefonts{%
+ \let\tenrm=\titlerm \let\tenit=\titleit \let\tensl=\titlesl
+ \let\tenbf=\titlebf \let\tentt=\titlett \let\smallcaps=\titlesc
+ \let\tensf=\titlesf \let\teni=\titlei \let\tensy=\titlesy
+ \let\tenttsl=\titlettsl
+ \def\curfontsize{title}%
+ \def\lsize{chap}\def\lllsize{subsec}%
+ \resetmathfonts \setleading{25pt}}
+\def\titlefont#1{{\titlefonts\rm #1}}
+\def\chapfonts{%
+ \let\tenrm=\chaprm \let\tenit=\chapit \let\tensl=\chapsl
+ \let\tenbf=\chapbf \let\tentt=\chaptt \let\smallcaps=\chapsc
+ \let\tensf=\chapsf \let\teni=\chapi \let\tensy=\chapsy
+ \let\tenttsl=\chapttsl
+ \def\curfontsize{chap}%
+ \def\lsize{sec}\def\lllsize{text}%
+ \resetmathfonts \setleading{19pt}}
+\def\secfonts{%
+ \let\tenrm=\secrm \let\tenit=\secit \let\tensl=\secsl
+ \let\tenbf=\secbf \let\tentt=\sectt \let\smallcaps=\secsc
+ \let\tensf=\secsf \let\teni=\seci \let\tensy=\secsy
+ \let\tenttsl=\secttsl
+ \def\curfontsize{sec}%
+ \def\lsize{subsec}\def\lllsize{reduced}%
+ \resetmathfonts \setleading{16pt}}
+\def\subsecfonts{%
+ \let\tenrm=\ssecrm \let\tenit=\ssecit \let\tensl=\ssecsl
+ \let\tenbf=\ssecbf \let\tentt=\ssectt \let\smallcaps=\ssecsc
+ \let\tensf=\ssecsf \let\teni=\sseci \let\tensy=\ssecsy
+ \let\tenttsl=\ssecttsl
+ \def\curfontsize{ssec}%
+ \def\lsize{text}\def\lllsize{small}%
+ \resetmathfonts \setleading{15pt}}
+\let\subsubsecfonts = \subsecfonts
+\def\reducedfonts{%
+ \let\tenrm=\reducedrm \let\tenit=\reducedit \let\tensl=\reducedsl
+ \let\tenbf=\reducedbf \let\tentt=\reducedtt \let\reducedcaps=\reducedsc
+ \let\tensf=\reducedsf \let\teni=\reducedi \let\tensy=\reducedsy
+ \let\tenttsl=\reducedttsl
+ \def\curfontsize{reduced}%
+ \def\lsize{small}\def\lllsize{smaller}%
+ \resetmathfonts \setleading{10.5pt}}
+\def\smallfonts{%
+ \let\tenrm=\smallrm \let\tenit=\smallit \let\tensl=\smallsl
+ \let\tenbf=\smallbf \let\tentt=\smalltt \let\smallcaps=\smallsc
+ \let\tensf=\smallsf \let\teni=\smalli \let\tensy=\smallsy
+ \let\tenttsl=\smallttsl
+ \def\curfontsize{small}%
+ \def\lsize{smaller}\def\lllsize{smaller}%
+ \resetmathfonts \setleading{10.5pt}}
+\def\smallerfonts{%
+ \let\tenrm=\smallerrm \let\tenit=\smallerit \let\tensl=\smallersl
+ \let\tenbf=\smallerbf \let\tentt=\smallertt \let\smallcaps=\smallersc
+ \let\tensf=\smallersf \let\teni=\smalleri \let\tensy=\smallersy
+ \let\tenttsl=\smallerttsl
+ \def\curfontsize{smaller}%
+ \def\lsize{smaller}\def\lllsize{smaller}%
+ \resetmathfonts \setleading{9.5pt}}
+
+% Set the fonts to use with the @small... environments.
+\let\smallexamplefonts = \smallfonts
+
+% About \smallexamplefonts. If we use \smallfonts (9pt), @smallexample
+% can fit this many characters:
+% 8.5x11=86 smallbook=72 a4=90 a5=69
+% If we use \scriptfonts (8pt), then we can fit this many characters:
+% 8.5x11=90+ smallbook=80 a4=90+ a5=77
+% For me, subjectively, the few extra characters that fit aren't worth
+% the additional smallness of 8pt. So I'm making the default 9pt.
+%
+% By the way, for comparison, here's what fits with @example (10pt):
+% 8.5x11=71 smallbook=60 a4=75 a5=58
+%
+% I wish the USA used A4 paper.
+% --karl, 24jan03.
+
+
+% Set up the default fonts, so we can use them for creating boxes.
+%
+\definetextfontsizexi
+
+% Define these so they can be easily changed for other fonts.
+\def\angleleft{$\langle$}
+\def\angleright{$\rangle$}
+
+% Count depth in font-changes, for error checks
+\newcount\fontdepth \fontdepth=0
+
+% Fonts for short table of contents.
+\setfont\shortcontrm\rmshape{12}{1000}{OT1}
+\setfont\shortcontbf\bfshape{10}{\magstep1}{OT1} % no cmb12
+\setfont\shortcontsl\slshape{12}{1000}{OT1}
+\setfont\shortconttt\ttshape{12}{1000}{OT1TT}
+
+%% Add scribe-like font environments, plus @l for inline lisp (usually sans
+%% serif) and @ii for TeX italic
+
+% \smartitalic{ARG} outputs arg in italics, followed by an italic correction
+% unless the following character is such as not to need one.
+\def\smartitalicx{\ifx\next,\else\ifx\next-\else\ifx\next.\else
+ \ptexslash\fi\fi\fi}
+\def\smartslanted#1{{\ifusingtt\ttsl\sl #1}\futurelet\next\smartitalicx}
+\def\smartitalic#1{{\ifusingtt\ttsl\it #1}\futurelet\next\smartitalicx}
+
+% like \smartslanted except unconditionally uses \ttsl.
+% @var is set to this for defun arguments.
+\def\ttslanted#1{{\ttsl #1}\futurelet\next\smartitalicx}
+
+% like \smartslanted except unconditionally use \sl. We never want
+% ttsl for book titles, do we?
+\def\cite#1{{\sl #1}\futurelet\next\smartitalicx}
+
+\let\i=\smartitalic
+\let\slanted=\smartslanted
+\let\var=\smartslanted
+\let\dfn=\smartslanted
+\let\emph=\smartitalic
+
+% @b, explicit bold.
+\def\b#1{{\bf #1}}
+\let\strong=\b
+
+% @sansserif, explicit sans.
+\def\sansserif#1{{\sf #1}}
+
+% We can't just use \exhyphenpenalty, because that only has effect at
+% the end of a paragraph. Restore normal hyphenation at the end of the
+% group within which \nohyphenation is presumably called.
+%
+\def\nohyphenation{\hyphenchar\font = -1 \aftergroup\restorehyphenation}
+\def\restorehyphenation{\hyphenchar\font = `- }
+
+% Set sfcode to normal for the chars that usually have another value.
+% Can't use plain's \frenchspacing because it uses the `\x notation, and
+% sometimes \x has an active definition that messes things up.
+%
+\catcode`@=11
+ \def\plainfrenchspacing{%
+ \sfcode\dotChar =\@m \sfcode\questChar=\@m \sfcode\exclamChar=\@m
+ \sfcode\colonChar=\@m \sfcode\semiChar =\@m \sfcode\commaChar =\@m
+ \def\endofsentencespacefactor{1000}% for @. and friends
+ }
+ \def\plainnonfrenchspacing{%
+ \sfcode`\.3000\sfcode`\?3000\sfcode`\!3000
+ \sfcode`\:2000\sfcode`\;1500\sfcode`\,1250
+ \def\endofsentencespacefactor{3000}% for @. and friends
+ }
+\catcode`@=\other
+\def\endofsentencespacefactor{3000}% default
+
+\def\t#1{%
+ {\tt \rawbackslash \plainfrenchspacing #1}%
+ \null
+}
+\def\samp#1{`\tclose{#1}'\null}
+\setfont\keyrm\rmshape{8}{1000}{OT1}
+\font\keysy=cmsy9
+\def\key#1{{\keyrm\textfont2=\keysy \leavevmode\hbox{%
+ \raise0.4pt\hbox{\angleleft}\kern-.08em\vtop{%
+ \vbox{\hrule\kern-0.4pt
+ \hbox{\raise0.4pt\hbox{\vphantom{\angleleft}}#1}}%
+ \kern-0.4pt\hrule}%
+ \kern-.06em\raise0.4pt\hbox{\angleright}}}}
+\def\key #1{{\nohyphenation \uppercase{#1}}\null}
+% The old definition, with no lozenge:
+%\def\key #1{{\ttsl \nohyphenation \uppercase{#1}}\null}
+\def\ctrl #1{{\tt \rawbackslash \hat}#1}
+
+% @file, @option are the same as @samp.
+\let\file=\samp
+\let\option=\samp
+
+% @code is a modification of @t,
+% which makes spaces the same size as normal in the surrounding text.
+\def\tclose#1{%
+ {%
+ % Change normal interword space to be same as for the current font.
+ \spaceskip = \fontdimen2\font
+ %
+ % Switch to typewriter.
+ \tt
+ %
+ % But `\ ' produces the large typewriter interword space.
+ \def\ {{\spaceskip = 0pt{} }}%
+ %
+ % Turn off hyphenation.
+ \nohyphenation
+ %
+ \rawbackslash
+ \plainfrenchspacing
+ #1%
+ }%
+ \null
+}
+
+% We *must* turn on hyphenation at `-' and `_' in @code.
+% Otherwise, it is too hard to avoid overfull hboxes
+% in the Emacs manual, the Library manual, etc.
+
+% Unfortunately, TeX uses one parameter (\hyphenchar) to control
+% both hyphenation at - and hyphenation within words.
+% We must therefore turn them both off (\tclose does that)
+% and arrange explicitly to hyphenate at a dash.
+% -- rms.
+{
+ \catcode`\-=\active \catcode`\_=\active
+ \catcode`\'=\active \catcode`\`=\active
+ %
+ \global\def\code{\begingroup
+ \catcode\rquoteChar=\active \catcode\lquoteChar=\active
+ \let'\codequoteright \let`\codequoteleft
+ %
+ \catcode\dashChar=\active \catcode\underChar=\active
+ \ifallowcodebreaks
+ \let-\codedash
+ \let_\codeunder
+ \else
+ \let-\realdash
+ \let_\realunder
+ \fi
+ \codex
+ }
+}
+
+\def\realdash{-}
+\def\codedash{-\discretionary{}{}{}}
+\def\codeunder{%
+ % this is all so @math{@code{var_name}+1} can work. In math mode, _
+ % is "active" (mathcode"8000) and \normalunderscore (or \char95, etc.)
+ % will therefore expand the active definition of _, which is us
+ % (inside @code that is), therefore an endless loop.
+ \ifusingtt{\ifmmode
+ \mathchar"075F % class 0=ordinary, family 7=ttfam, pos 0x5F=_.
+ \else\normalunderscore \fi
+ \discretionary{}{}{}}%
+ {\_}%
+}
+\def\codex #1{\tclose{#1}\endgroup}
+
+% An additional complication: the above will allow breaks after, e.g.,
+% each of the four underscores in __typeof__. This is undesirable in
+% some manuals, especially if they don't have long identifiers in
+% general. @allowcodebreaks provides a way to control this.
+%
+\newif\ifallowcodebreaks \allowcodebreakstrue
+
+\def\keywordtrue{true}
+\def\keywordfalse{false}
+
+\parseargdef\allowcodebreaks{%
+ \def\txiarg{#1}%
+ \ifx\txiarg\keywordtrue
+ \allowcodebreakstrue
+ \else\ifx\txiarg\keywordfalse
+ \allowcodebreaksfalse
+ \else
+ \errhelp = \EMsimple
+ \errmessage{Unknown @allowcodebreaks option `\txiarg'}%
+ \fi\fi
+}
+
+% @kbd is like @code, except that if the argument is just one @key command,
+% then @kbd has no effect.
+
+% @kbdinputstyle -- arg is `distinct' (@kbd uses slanted tty font always),
+% `example' (@kbd uses ttsl only inside of @example and friends),
+% or `code' (@kbd uses normal tty font always).
+\parseargdef\kbdinputstyle{%
+ \def\txiarg{#1}%
+ \ifx\txiarg\worddistinct
+ \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\ttsl}%
+ \else\ifx\txiarg\wordexample
+ \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\tt}%
+ \else\ifx\txiarg\wordcode
+ \gdef\kbdexamplefont{\tt}\gdef\kbdfont{\tt}%
+ \else
+ \errhelp = \EMsimple
+ \errmessage{Unknown @kbdinputstyle option `\txiarg'}%
+ \fi\fi\fi
+}
+\def\worddistinct{distinct}
+\def\wordexample{example}
+\def\wordcode{code}
+
+% Default is `distinct.'
+\kbdinputstyle distinct
+
+\def\xkey{\key}
+\def\kbdfoo#1#2#3\par{\def\one{#1}\def\three{#3}\def\threex{??}%
+\ifx\one\xkey\ifx\threex\three \key{#2}%
+\else{\tclose{\kbdfont\look}}\fi
+\else{\tclose{\kbdfont\look}}\fi}
+
+% For @indicateurl, @env, @command quotes seem unnecessary, so use \code.
+\let\indicateurl=\code
+\let\env=\code
+\let\command=\code
+
+% @uref (abbreviation for `urlref') takes an optional (comma-separated)
+% second argument specifying the text to display and an optional third
+% arg as text to display instead of (rather than in addition to) the url
+% itself. First (mandatory) arg is the url. Perhaps eventually put in
+% a hypertex \special here.
+%
+\def\uref#1{\douref #1,,,\finish}
+\def\douref#1,#2,#3,#4\finish{\begingroup
+ \unsepspaces
+ \pdfurl{#1}%
+ \setbox0 = \hbox{\ignorespaces #3}%
+ \ifdim\wd0 > 0pt
+ \unhbox0 % third arg given, show only that
+ \else
+ \setbox0 = \hbox{\ignorespaces #2}%
+ \ifdim\wd0 > 0pt
+ \ifpdf
+ \unhbox0 % PDF: 2nd arg given, show only it
+ \else
+ \unhbox0\ (\code{#1})% DVI: 2nd arg given, show both it and url
+ \fi
+ \else
+ \code{#1}% only url given, so show it
+ \fi
+ \fi
+ \endlink
+\endgroup}
+
+% @url synonym for @uref, since that's how everyone uses it.
+%
+\let\url=\uref
+
+% rms does not like angle brackets --karl, 17may97.
+% So now @email is just like @uref, unless we are pdf.
+%
+%\def\email#1{\angleleft{\tt #1}\angleright}
+\ifpdf
+ \def\email#1{\doemail#1,,\finish}
+ \def\doemail#1,#2,#3\finish{\begingroup
+ \unsepspaces
+ \pdfurl{mailto:#1}%
+ \setbox0 = \hbox{\ignorespaces #2}%
+ \ifdim\wd0>0pt\unhbox0\else\code{#1}\fi
+ \endlink
+ \endgroup}
+\else
+ \let\email=\uref
+\fi
+
+% Check if we are currently using a typewriter font. Since all the
+% Computer Modern typewriter fonts have zero interword stretch (and
+% shrink), and it is reasonable to expect all typewriter fonts to have
+% this property, we can check that font parameter.
+%
+\def\ifmonospace{\ifdim\fontdimen3\font=0pt }
+
+% Typeset a dimension, e.g., `in' or `pt'. The only reason for the
+% argument is to make the input look right: @dmn{pt} instead of @dmn{}pt.
+%
+\def\dmn#1{\thinspace #1}
+
+\def\kbd#1{\def\look{#1}\expandafter\kbdfoo\look??\par}
+
+% @l was never documented to mean ``switch to the Lisp font'',
+% and it is not used as such in any manual I can find. We need it for
+% Polish suppressed-l. --karl, 22sep96.
+%\def\l#1{{\li #1}\null}
+
+% Explicit font changes: @r, @sc, undocumented @ii.
+\def\r#1{{\rm #1}} % roman font
+\def\sc#1{{\smallcaps#1}} % smallcaps font
+\def\ii#1{{\it #1}} % italic font
+
+% @acronym for "FBI", "NATO", and the like.
+% We print this one point size smaller, since it's intended for
+% all-uppercase.
+%
+\def\acronym#1{\doacronym #1,,\finish}
+\def\doacronym#1,#2,#3\finish{%
+ {\selectfonts\lsize #1}%
+ \def\temp{#2}%
+ \ifx\temp\empty \else
+ \space ({\unsepspaces \ignorespaces \temp \unskip})%
+ \fi
+}
+
+% @abbr for "Comput. J." and the like.
+% No font change, but don't do end-of-sentence spacing.
+%
+\def\abbr#1{\doabbr #1,,\finish}
+\def\doabbr#1,#2,#3\finish{%
+ {\plainfrenchspacing #1}%
+ \def\temp{#2}%
+ \ifx\temp\empty \else
+ \space ({\unsepspaces \ignorespaces \temp \unskip})%
+ \fi
+}
+
+% @pounds{} is a sterling sign, which Knuth put in the CM italic font.
+%
+\def\pounds{{\it\$}}
+
+% @euro{} comes from a separate font, depending on the current style.
+% We use the free feym* fonts from the eurosym package by Henrik
+% Theiling, which support regular, slanted, bold and bold slanted (and
+% "outlined" (blackboard board, sort of) versions, which we don't need).
+% It is available from http://www.ctan.org/tex-archive/fonts/eurosym.
+%
+% Although only regular is the truly official Euro symbol, we ignore
+% that. The Euro is designed to be slightly taller than the regular
+% font height.
+%
+% feymr - regular
+% feymo - slanted
+% feybr - bold
+% feybo - bold slanted
+%
+% There is no good (free) typewriter version, to my knowledge.
+% A feymr10 euro is ~7.3pt wide, while a normal cmtt10 char is ~5.25pt wide.
+% Hmm.
+%
+% Also doesn't work in math. Do we need to do math with euro symbols?
+% Hope not.
+%
+%
+\def\euro{{\eurofont e}}
+\def\eurofont{%
+ % We set the font at each command, rather than predefining it in
+ % \textfonts and the other font-switching commands, so that
+ % installations which never need the symbol don't have to have the
+ % font installed.
+ %
+ % There is only one designed size (nominal 10pt), so we always scale
+ % that to the current nominal size.
+ %
+ % By the way, simply using "at 1em" works for cmr10 and the like, but
+ % does not work for cmbx10 and other extended/shrunken fonts.
+ %
+ \def\eurosize{\csname\curfontsize nominalsize\endcsname}%
+ %
+ \ifx\curfontstyle\bfstylename
+ % bold:
+ \font\thiseurofont = \ifusingit{feybo10}{feybr10} at \eurosize
+ \else
+ % regular:
+ \font\thiseurofont = \ifusingit{feymo10}{feymr10} at \eurosize
+ \fi
+ \thiseurofont
+}
+
+% Hacks for glyphs from the EC fonts similar to \euro. We don't
+% use \let for the aliases, because sometimes we redefine the original
+% macro, and the alias should reflect the redefinition.
+\def\guillemetleft{{\ecfont \char"13}}
+\def\guillemotleft{\guillemetleft}
+\def\guillemetright{{\ecfont \char"14}}
+\def\guillemotright{\guillemetright}
+\def\guilsinglleft{{\ecfont \char"0E}}
+\def\guilsinglright{{\ecfont \char"0F}}
+\def\quotedblbase{{\ecfont \char"12}}
+\def\quotesinglbase{{\ecfont \char"0D}}
+%
+\def\ecfont{%
+ % We can't distinguish serif/sanserif and italic/slanted, but this
+ % is used for crude hacks anyway (like adding French and German
+ % quotes to documents typeset with CM, where we lose kerning), so
+ % hopefully nobody will notice/care.
+ \edef\ecsize{\csname\curfontsize ecsize\endcsname}%
+ \edef\nominalsize{\csname\curfontsize nominalsize\endcsname}%
+ \ifx\curfontstyle\bfstylename
+ % bold:
+ \font\thisecfont = ecb\ifusingit{i}{x}\ecsize \space at \nominalsize
+ \else
+ % regular:
+ \font\thisecfont = ec\ifusingit{ti}{rm}\ecsize \space at \nominalsize
+ \fi
+ \thisecfont
+}
+
+% @registeredsymbol - R in a circle. The font for the R should really
+% be smaller yet, but lllsize is the best we can do for now.
+% Adapted from the plain.tex definition of \copyright.
+%
+\def\registeredsymbol{%
+ $^{{\ooalign{\hfil\raise.07ex\hbox{\selectfonts\lllsize R}%
+ \hfil\crcr\Orb}}%
+ }$%
+}
+
+% @textdegree - the normal degrees sign.
+%
+\def\textdegree{$^\circ$}
+
+% Laurent Siebenmann reports \Orb undefined with:
+% Textures 1.7.7 (preloaded format=plain 93.10.14) (68K) 16 APR 2004 02:38
+% so we'll define it if necessary.
+%
+\ifx\Orb\undefined
+\def\Orb{\mathhexbox20D}
+\fi
+
+% Quotes.
+\chardef\quotedblleft="5C
+\chardef\quotedblright=`\"
+\chardef\quoteleft=`\`
+\chardef\quoteright=`\'
+
+
+\message{page headings,}
+
+\newskip\titlepagetopglue \titlepagetopglue = 1.5in
+\newskip\titlepagebottomglue \titlepagebottomglue = 2pc
+
+% First the title page. Must do @settitle before @titlepage.
+\newif\ifseenauthor
+\newif\iffinishedtitlepage
+
+% Do an implicit @contents or @shortcontents after @end titlepage if the
+% user says @setcontentsaftertitlepage or @setshortcontentsaftertitlepage.
+%
+\newif\ifsetcontentsaftertitlepage
+ \let\setcontentsaftertitlepage = \setcontentsaftertitlepagetrue
+\newif\ifsetshortcontentsaftertitlepage
+ \let\setshortcontentsaftertitlepage = \setshortcontentsaftertitlepagetrue
+
+\parseargdef\shorttitlepage{\begingroup\hbox{}\vskip 1.5in \chaprm \centerline{#1}%
+ \endgroup\page\hbox{}\page}
+
+\envdef\titlepage{%
+ % Open one extra group, as we want to close it in the middle of \Etitlepage.
+ \begingroup
+ \parindent=0pt \textfonts
+ % Leave some space at the very top of the page.
+ \vglue\titlepagetopglue
+ % No rule at page bottom unless we print one at the top with @title.
+ \finishedtitlepagetrue
+ %
+ % Most title ``pages'' are actually two pages long, with space
+ % at the top of the second. We don't want the ragged left on the second.
+ \let\oldpage = \page
+ \def\page{%
+ \iffinishedtitlepage\else
+ \finishtitlepage
+ \fi
+ \let\page = \oldpage
+ \page
+ \null
+ }%
+}
+
+\def\Etitlepage{%
+ \iffinishedtitlepage\else
+ \finishtitlepage
+ \fi
+ % It is important to do the page break before ending the group,
+ % because the headline and footline are only empty inside the group.
+ % If we use the new definition of \page, we always get a blank page
+ % after the title page, which we certainly don't want.
+ \oldpage
+ \endgroup
+ %
+ % Need this before the \...aftertitlepage checks so that if they are
+ % in effect the toc pages will come out with page numbers.
+ \HEADINGSon
+ %
+ % If they want short, they certainly want long too.
+ \ifsetshortcontentsaftertitlepage
+ \shortcontents
+ \contents
+ \global\let\shortcontents = \relax
+ \global\let\contents = \relax
+ \fi
+ %
+ \ifsetcontentsaftertitlepage
+ \contents
+ \global\let\contents = \relax
+ \global\let\shortcontents = \relax
+ \fi
+}
+
+\def\finishtitlepage{%
+ \vskip4pt \hrule height 2pt width \hsize
+ \vskip\titlepagebottomglue
+ \finishedtitlepagetrue
+}
+
+%%% Macros to be used within @titlepage:
+
+\let\subtitlerm=\tenrm
+\def\subtitlefont{\subtitlerm \normalbaselineskip = 13pt \normalbaselines}
+
+\def\authorfont{\authorrm \normalbaselineskip = 16pt \normalbaselines
+ \let\tt=\authortt}
+
+\parseargdef\title{%
+ \checkenv\titlepage
+ \leftline{\titlefonts\rm #1}
+ % print a rule at the page bottom also.
+ \finishedtitlepagefalse
+ \vskip4pt \hrule height 4pt width \hsize \vskip4pt
+}
+
+\parseargdef\subtitle{%
+ \checkenv\titlepage
+ {\subtitlefont \rightline{#1}}%
+}
+
+% @author should come last, but may come many times.
+% It can also be used inside @quotation.
+%
+\parseargdef\author{%
+ \def\temp{\quotation}%
+ \ifx\thisenv\temp
+ \def\quotationauthor{#1}% printed in \Equotation.
+ \else
+ \checkenv\titlepage
+ \ifseenauthor\else \vskip 0pt plus 1filll \seenauthortrue \fi
+ {\authorfont \leftline{#1}}%
+ \fi
+}
+
+
+%%% Set up page headings and footings.
+
+\let\thispage=\folio
+
+\newtoks\evenheadline % headline on even pages
+\newtoks\oddheadline % headline on odd pages
+\newtoks\evenfootline % footline on even pages
+\newtoks\oddfootline % footline on odd pages
+
+% Now make TeX use those variables
+\headline={{\textfonts\rm \ifodd\pageno \the\oddheadline
+ \else \the\evenheadline \fi}}
+\footline={{\textfonts\rm \ifodd\pageno \the\oddfootline
+ \else \the\evenfootline \fi}\HEADINGShook}
+\let\HEADINGShook=\relax
+
+% Commands to set those variables.
+% For example, this is what @headings on does
+% @evenheading @thistitle|@thispage|@thischapter
+% @oddheading @thischapter|@thispage|@thistitle
+% @evenfooting @thisfile||
+% @oddfooting ||@thisfile
+
+
+\def\evenheading{\parsearg\evenheadingxxx}
+\def\evenheadingxxx #1{\evenheadingyyy #1\|\|\|\|\finish}
+\def\evenheadingyyy #1\|#2\|#3\|#4\finish{%
+\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
+
+\def\oddheading{\parsearg\oddheadingxxx}
+\def\oddheadingxxx #1{\oddheadingyyy #1\|\|\|\|\finish}
+\def\oddheadingyyy #1\|#2\|#3\|#4\finish{%
+\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
+
+\parseargdef\everyheading{\oddheadingxxx{#1}\evenheadingxxx{#1}}%
+
+\def\evenfooting{\parsearg\evenfootingxxx}
+\def\evenfootingxxx #1{\evenfootingyyy #1\|\|\|\|\finish}
+\def\evenfootingyyy #1\|#2\|#3\|#4\finish{%
+\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
+
+\def\oddfooting{\parsearg\oddfootingxxx}
+\def\oddfootingxxx #1{\oddfootingyyy #1\|\|\|\|\finish}
+\def\oddfootingyyy #1\|#2\|#3\|#4\finish{%
+ \global\oddfootline = {\rlap{\centerline{#2}}\line{#1\hfil#3}}%
+ %
+ % Leave some space for the footline. Hopefully ok to assume
+ % @evenfooting will not be used by itself.
+ \global\advance\pageheight by -12pt
+ \global\advance\vsize by -12pt
+}
+
+\parseargdef\everyfooting{\oddfootingxxx{#1}\evenfootingxxx{#1}}
+
+% @evenheadingmarks top \thischapter <- chapter at the top of a page
+% @evenheadingmarks bottom \thischapter <- chapter at the bottom of a page
+%
+% The same set of arguments for:
+%
+% @oddheadingmarks
+% @evenfootingmarks
+% @oddfootingmarks
+% @everyheadingmarks
+% @everyfootingmarks
+
+\def\evenheadingmarks{\headingmarks{even}{heading}}
+\def\oddheadingmarks{\headingmarks{odd}{heading}}
+\def\evenfootingmarks{\headingmarks{even}{footing}}
+\def\oddfootingmarks{\headingmarks{odd}{footing}}
+\def\everyheadingmarks#1 {\headingmarks{even}{heading}{#1}
+ \headingmarks{odd}{heading}{#1} }
+\def\everyfootingmarks#1 {\headingmarks{even}{footing}{#1}
+ \headingmarks{odd}{footing}{#1} }
+% #1 = even/odd, #2 = heading/footing, #3 = top/bottom.
+\def\headingmarks#1#2#3 {%
+ \expandafter\let\expandafter\temp \csname get#3headingmarks\endcsname
+ \global\expandafter\let\csname get#1#2marks\endcsname \temp
+}
+
+\everyheadingmarks bottom
+\everyfootingmarks bottom
+
+% @headings double turns headings on for double-sided printing.
+% @headings single turns headings on for single-sided printing.
+% @headings off turns them off.
+% @headings on same as @headings double, retained for compatibility.
+% @headings after turns on double-sided headings after this page.
+% @headings doubleafter turns on double-sided headings after this page.
+% @headings singleafter turns on single-sided headings after this page.
+% By default, they are off at the start of a document,
+% and turned `on' after @end titlepage.
+
+\def\headings #1 {\csname HEADINGS#1\endcsname}
+
+\def\HEADINGSoff{%
+\global\evenheadline={\hfil} \global\evenfootline={\hfil}
+\global\oddheadline={\hfil} \global\oddfootline={\hfil}}
+\HEADINGSoff
+% When we turn headings on, set the page number to 1.
+% For double-sided printing, put current file name in lower left corner,
+% chapter name on inside top of right hand pages, document
+% title on inside top of left hand pages, and page numbers on outside top
+% edge of all pages.
+\def\HEADINGSdouble{%
+\global\pageno=1
+\global\evenfootline={\hfil}
+\global\oddfootline={\hfil}
+\global\evenheadline={\line{\folio\hfil\thistitle}}
+\global\oddheadline={\line{\thischapter\hfil\folio}}
+\global\let\contentsalignmacro = \chapoddpage
+}
+\let\contentsalignmacro = \chappager
+
+% For single-sided printing, chapter title goes across top left of page,
+% page number on top right.
+\def\HEADINGSsingle{%
+\global\pageno=1
+\global\evenfootline={\hfil}
+\global\oddfootline={\hfil}
+\global\evenheadline={\line{\thischapter\hfil\folio}}
+\global\oddheadline={\line{\thischapter\hfil\folio}}
+\global\let\contentsalignmacro = \chappager
+}
+\def\HEADINGSon{\HEADINGSdouble}
+
+\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex}
+\let\HEADINGSdoubleafter=\HEADINGSafter
+\def\HEADINGSdoublex{%
+\global\evenfootline={\hfil}
+\global\oddfootline={\hfil}
+\global\evenheadline={\line{\folio\hfil\thistitle}}
+\global\oddheadline={\line{\thischapter\hfil\folio}}
+\global\let\contentsalignmacro = \chapoddpage
+}
+
+\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex}
+\def\HEADINGSsinglex{%
+\global\evenfootline={\hfil}
+\global\oddfootline={\hfil}
+\global\evenheadline={\line{\thischapter\hfil\folio}}
+\global\oddheadline={\line{\thischapter\hfil\folio}}
+\global\let\contentsalignmacro = \chappager
+}
+
+% Subroutines used in generating headings
+% This produces Day Month Year style of output.
+% Only define if not already defined, in case a txi-??.tex file has set
+% up a different format (e.g., txi-cs.tex does this).
+\ifx\today\undefined
+\def\today{%
+ \number\day\space
+ \ifcase\month
+ \or\putwordMJan\or\putwordMFeb\or\putwordMMar\or\putwordMApr
+ \or\putwordMMay\or\putwordMJun\or\putwordMJul\or\putwordMAug
+ \or\putwordMSep\or\putwordMOct\or\putwordMNov\or\putwordMDec
+ \fi
+ \space\number\year}
+\fi
+
+% @settitle line... specifies the title of the document, for headings.
+% It generates no output of its own.
+\def\thistitle{\putwordNoTitle}
+\def\settitle{\parsearg{\gdef\thistitle}}
+
+
+\message{tables,}
+% Tables -- @table, @ftable, @vtable, @item(x).
+
+% default indentation of table text
+\newdimen\tableindent \tableindent=.8in
+% default indentation of @itemize and @enumerate text
+\newdimen\itemindent \itemindent=.3in
+% margin between end of table item and start of table text.
+\newdimen\itemmargin \itemmargin=.1in
+
+% used internally for \itemindent minus \itemmargin
+\newdimen\itemmax
+
+% Note @table, @ftable, and @vtable define @item, @itemx, etc., with
+% these defs.
+% They also define \itemindex
+% to index the item name in whatever manner is desired (perhaps none).
+
+\newif\ifitemxneedsnegativevskip
+
+\def\itemxpar{\par\ifitemxneedsnegativevskip\nobreak\vskip-\parskip\nobreak\fi}
+
+\def\internalBitem{\smallbreak \parsearg\itemzzz}
+\def\internalBitemx{\itemxpar \parsearg\itemzzz}
+
+\def\itemzzz #1{\begingroup %
+ \advance\hsize by -\rightskip
+ \advance\hsize by -\tableindent
+ \setbox0=\hbox{\itemindicate{#1}}%
+ \itemindex{#1}%
+ \nobreak % This prevents a break before @itemx.
+ %
+ % If the item text does not fit in the space we have, put it on a line
+ % by itself, and do not allow a page break either before or after that
+ % line. We do not start a paragraph here because then if the next
+ % command is, e.g., @kindex, the whatsit would get put into the
+ % horizontal list on a line by itself, resulting in extra blank space.
+ \ifdim \wd0>\itemmax
+ %
+ % Make this a paragraph so we get the \parskip glue and wrapping,
+ % but leave it ragged-right.
+ \begingroup
+ \advance\leftskip by-\tableindent
+ \advance\hsize by\tableindent
+ \advance\rightskip by0pt plus1fil
+ \leavevmode\unhbox0\par
+ \endgroup
+ %
+ % We're going to be starting a paragraph, but we don't want the
+ % \parskip glue -- logically it's part of the @item we just started.
+ \nobreak \vskip-\parskip
+ %
+ % Stop a page break at the \parskip glue coming up. However, if
+ % what follows is an environment such as @example, there will be no
+ % \parskip glue; then the negative vskip we just inserted would
+ % cause the example and the item to crash together. So we use this
+ % bizarre value of 10001 as a signal to \aboveenvbreak to insert
+ % \parskip glue after all. Section titles are handled this way also.
+ %
+ \penalty 10001
+ \endgroup
+ \itemxneedsnegativevskipfalse
+ \else
+ % The item text fits into the space. Start a paragraph, so that the
+ % following text (if any) will end up on the same line.
+ \noindent
+ % Do this with kerns and \unhbox so that if there is a footnote in
+ % the item text, it can migrate to the main vertical list and
+ % eventually be printed.
+ \nobreak\kern-\tableindent
+ \dimen0 = \itemmax \advance\dimen0 by \itemmargin \advance\dimen0 by -\wd0
+ \unhbox0
+ \nobreak\kern\dimen0
+ \endgroup
+ \itemxneedsnegativevskiptrue
+ \fi
+}
+
+\def\item{\errmessage{@item while not in a list environment}}
+\def\itemx{\errmessage{@itemx while not in a list environment}}
+
+% @table, @ftable, @vtable.
+\envdef\table{%
+ \let\itemindex\gobble
+ \tablecheck{table}%
+}
+\envdef\ftable{%
+ \def\itemindex ##1{\doind {fn}{\code{##1}}}%
+ \tablecheck{ftable}%
+}
+\envdef\vtable{%
+ \def\itemindex ##1{\doind {vr}{\code{##1}}}%
+ \tablecheck{vtable}%
+}
+\def\tablecheck#1{%
+ \ifnum \the\catcode`\^^M=\active
+ \endgroup
+ \errmessage{This command won't work in this context; perhaps the problem is
+ that we are \inenvironment\thisenv}%
+ \def\next{\doignore{#1}}%
+ \else
+ \let\next\tablex
+ \fi
+ \next
+}
+\def\tablex#1{%
+ \def\itemindicate{#1}%
+ \parsearg\tabley
+}
+\def\tabley#1{%
+ {%
+ \makevalueexpandable
+ \edef\temp{\noexpand\tablez #1\space\space\space}%
+ \expandafter
+ }\temp \endtablez
+}
+\def\tablez #1 #2 #3 #4\endtablez{%
+ \aboveenvbreak
+ \ifnum 0#1>0 \advance \leftskip by #1\mil \fi
+ \ifnum 0#2>0 \tableindent=#2\mil \fi
+ \ifnum 0#3>0 \advance \rightskip by #3\mil \fi
+ \itemmax=\tableindent
+ \advance \itemmax by -\itemmargin
+ \advance \leftskip by \tableindent
+ \exdentamount=\tableindent
+ \parindent = 0pt
+ \parskip = \smallskipamount
+ \ifdim \parskip=0pt \parskip=2pt \fi
+ \let\item = \internalBitem
+ \let\itemx = \internalBitemx
+}
+\def\Etable{\endgraf\afterenvbreak}
+\let\Eftable\Etable
+\let\Evtable\Etable
+\let\Eitemize\Etable
+\let\Eenumerate\Etable
+
+% This is the counter used by @enumerate, which is really @itemize
+
+\newcount \itemno
+
+\envdef\itemize{\parsearg\doitemize}
+
+\def\doitemize#1{%
+ \aboveenvbreak
+ \itemmax=\itemindent
+ \advance\itemmax by -\itemmargin
+ \advance\leftskip by \itemindent
+ \exdentamount=\itemindent
+ \parindent=0pt
+ \parskip=\smallskipamount
+ \ifdim\parskip=0pt \parskip=2pt \fi
+ \def\itemcontents{#1}%
+ % @itemize with no arg is equivalent to @itemize @bullet.
+ \ifx\itemcontents\empty\def\itemcontents{\bullet}\fi
+ \let\item=\itemizeitem
+}
+
+% Definition of @item while inside @itemize and @enumerate.
+%
+\def\itemizeitem{%
+ \advance\itemno by 1 % for enumerations
+ {\let\par=\endgraf \smallbreak}% reasonable place to break
+ {%
+ % If the document has an @itemize directly after a section title, a
+ % \nobreak will be last on the list, and \sectionheading will have
+ % done a \vskip-\parskip. In that case, we don't want to zero
+ % parskip, or the item text will crash with the heading. On the
+ % other hand, when there is normal text preceding the item (as there
+ % usually is), we do want to zero parskip, or there would be too much
+ % space. In that case, we won't have a \nobreak before. At least
+ % that's the theory.
+ \ifnum\lastpenalty<10000 \parskip=0in \fi
+ \noindent
+ \hbox to 0pt{\hss \itemcontents \kern\itemmargin}%
+ \vadjust{\penalty 1200}}% not good to break after first line of item.
+ \flushcr
+}
+
+% \splitoff TOKENS\endmark defines \first to be the first token in
+% TOKENS, and \rest to be the remainder.
+%
+\def\splitoff#1#2\endmark{\def\first{#1}\def\rest{#2}}%
+
+% Allow an optional argument of an uppercase letter, lowercase letter,
+% or number, to specify the first label in the enumerated list. No
+% argument is the same as `1'.
+%
+\envparseargdef\enumerate{\enumeratey #1 \endenumeratey}
+\def\enumeratey #1 #2\endenumeratey{%
+ % If we were given no argument, pretend we were given `1'.
+ \def\thearg{#1}%
+ \ifx\thearg\empty \def\thearg{1}\fi
+ %
+ % Detect if the argument is a single token. If so, it might be a
+ % letter. Otherwise, the only valid thing it can be is a number.
+ % (We will always have one token, because of the test we just made.
+ % This is a good thing, since \splitoff doesn't work given nothing at
+ % all -- the first parameter is undelimited.)
+ \expandafter\splitoff\thearg\endmark
+ \ifx\rest\empty
+ % Only one token in the argument. It could still be anything.
+ % A ``lowercase letter'' is one whose \lccode is nonzero.
+ % An ``uppercase letter'' is one whose \lccode is both nonzero, and
+ % not equal to itself.
+ % Otherwise, we assume it's a number.
+ %
+ % We need the \relax at the end of the \ifnum lines to stop TeX from
+ % continuing to look for a <number>.
+ %
+ \ifnum\lccode\expandafter`\thearg=0\relax
+ \numericenumerate % a number (we hope)
+ \else
+ % It's a letter.
+ \ifnum\lccode\expandafter`\thearg=\expandafter`\thearg\relax
+ \lowercaseenumerate % lowercase letter
+ \else
+ \uppercaseenumerate % uppercase letter
+ \fi
+ \fi
+ \else
+ % Multiple tokens in the argument. We hope it's a number.
+ \numericenumerate
+ \fi
+}
+
+% An @enumerate whose labels are integers. The starting integer is
+% given in \thearg.
+%
+\def\numericenumerate{%
+ \itemno = \thearg
+ \startenumeration{\the\itemno}%
+}
+
+% The starting (lowercase) letter is in \thearg.
+\def\lowercaseenumerate{%
+ \itemno = \expandafter`\thearg
+ \startenumeration{%
+ % Be sure we're not beyond the end of the alphabet.
+ \ifnum\itemno=0
+ \errmessage{No more lowercase letters in @enumerate; get a bigger
+ alphabet}%
+ \fi
+ \char\lccode\itemno
+ }%
+}
+
+% The starting (uppercase) letter is in \thearg.
+\def\uppercaseenumerate{%
+ \itemno = \expandafter`\thearg
+ \startenumeration{%
+ % Be sure we're not beyond the end of the alphabet.
+ \ifnum\itemno=0
+ \errmessage{No more uppercase letters in @enumerate; get a bigger
+ alphabet}
+ \fi
+ \char\uccode\itemno
+ }%
+}
+
+% Call \doitemize, adding a period to the first argument and supplying the
+% common last two arguments. Also subtract one from the initial value in
+% \itemno, since @item increments \itemno.
+%
+\def\startenumeration#1{%
+ \advance\itemno by -1
+ \doitemize{#1.}\flushcr
+}
+
+% @alphaenumerate and @capsenumerate are abbreviations for giving an arg
+% to @enumerate.
+%
+\def\alphaenumerate{\enumerate{a}}
+\def\capsenumerate{\enumerate{A}}
+\def\Ealphaenumerate{\Eenumerate}
+\def\Ecapsenumerate{\Eenumerate}
+
+
+% @multitable macros
+% Amy Hendrickson, 8/18/94, 3/6/96
+%
+% @multitable ... @end multitable will make as many columns as desired.
+% Contents of each column will wrap at width given in preamble. Width
+% can be specified either with sample text given in a template line,
+% or in percent of \hsize, the current width of text on page.
+
+% Table can continue over pages but will only break between lines.
+
+% To make preamble:
+%
+% Either define widths of columns in terms of percent of \hsize:
+% @multitable @columnfractions .25 .3 .45
+% @item ...
+%
+% Numbers following @columnfractions are the percent of the total
+% current hsize to be used for each column. You may use as many
+% columns as desired.
+
+
+% Or use a template:
+% @multitable {Column 1 template} {Column 2 template} {Column 3 template}
+% @item ...
+% using the widest term desired in each column.
+
+% Each new table line starts with @item, each subsequent new column
+% starts with @tab. Empty columns may be produced by supplying @tab's
+% with nothing between them for as many times as empty columns are needed,
+% ie, @tab@tab@tab will produce two empty columns.
+
+% @item, @tab do not need to be on their own lines, but it will not hurt
+% if they are.
+
+% Sample multitable:
+
+% @multitable {Column 1 template} {Column 2 template} {Column 3 template}
+% @item first col stuff @tab second col stuff @tab third col
+% @item
+% first col stuff
+% @tab
+% second col stuff
+% @tab
+% third col
+% @item first col stuff @tab second col stuff
+% @tab Many paragraphs of text may be used in any column.
+%
+% They will wrap at the width determined by the template.
+% @item@tab@tab This will be in third column.
+% @end multitable
+
+% Default dimensions may be reset by user.
+% @multitableparskip is vertical space between paragraphs in table.
+% @multitableparindent is paragraph indent in table.
+% @multitablecolmargin is horizontal space to be left between columns.
+% @multitablelinespace is space to leave between table items, baseline
+% to baseline.
+% 0pt means it depends on current normal line spacing.
+%
+\newskip\multitableparskip
+\newskip\multitableparindent
+\newdimen\multitablecolspace
+\newskip\multitablelinespace
+\multitableparskip=0pt
+\multitableparindent=6pt
+\multitablecolspace=12pt
+\multitablelinespace=0pt
+
+% Macros used to set up halign preamble:
+%
+\let\endsetuptable\relax
+\def\xendsetuptable{\endsetuptable}
+\let\columnfractions\relax
+\def\xcolumnfractions{\columnfractions}
+\newif\ifsetpercent
+
+% #1 is the @columnfraction, usually a decimal number like .5, but might
+% be just 1. We just use it, whatever it is.
+%
+\def\pickupwholefraction#1 {%
+ \global\advance\colcount by 1
+ \expandafter\xdef\csname col\the\colcount\endcsname{#1\hsize}%
+ \setuptable
+}
+
+\newcount\colcount
+\def\setuptable#1{%
+ \def\firstarg{#1}%
+ \ifx\firstarg\xendsetuptable
+ \let\go = \relax
+ \else
+ \ifx\firstarg\xcolumnfractions
+ \global\setpercenttrue
+ \else
+ \ifsetpercent
+ \let\go\pickupwholefraction
+ \else
+ \global\advance\colcount by 1
+ \setbox0=\hbox{#1\unskip\space}% Add a normal word space as a
+ % separator; typically that is always in the input, anyway.
+ \expandafter\xdef\csname col\the\colcount\endcsname{\the\wd0}%
+ \fi
+ \fi
+ \ifx\go\pickupwholefraction
+ % Put the argument back for the \pickupwholefraction call, so
+ % we'll always have a period there to be parsed.
+ \def\go{\pickupwholefraction#1}%
+ \else
+ \let\go = \setuptable
+ \fi%
+ \fi
+ \go
+}
+
+% multitable-only commands.
+%
+% @headitem starts a heading row, which we typeset in bold.
+% Assignments have to be global since we are inside the implicit group
+% of an alignment entry. Note that \everycr resets \everytab.
+\def\headitem{\checkenv\multitable \crcr \global\everytab={\bf}\the\everytab}%
+%
+% A \tab used to include \hskip1sp. But then the space in a template
+% line is not enough. That is bad. So let's go back to just `&' until
+% we encounter the problem it was intended to solve again.
+% --karl, nathan@acm.org, 20apr99.
+\def\tab{\checkenv\multitable &\the\everytab}%
+
+% @multitable ... @end multitable definitions:
+%
+\newtoks\everytab % insert after every tab.
+%
+\envdef\multitable{%
+ \vskip\parskip
+ \startsavinginserts
+ %
+ % @item within a multitable starts a normal row.
+ % We use \def instead of \let so that if one of the multitable entries
+ % contains an @itemize, we don't choke on the \item (seen as \crcr aka
+ % \endtemplate) expanding \doitemize.
+ \def\item{\crcr}%
+ %
+ \tolerance=9500
+ \hbadness=9500
+ \setmultitablespacing
+ \parskip=\multitableparskip
+ \parindent=\multitableparindent
+ \overfullrule=0pt
+ \global\colcount=0
+ %
+ \everycr = {%
+ \noalign{%
+ \global\everytab={}%
+ \global\colcount=0 % Reset the column counter.
+ % Check for saved footnotes, etc.
+ \checkinserts
+ % Keeps underfull box messages off when table breaks over pages.
+ %\filbreak
+ % Maybe so, but it also creates really weird page breaks when the
+ % table breaks over pages. Wouldn't \vfil be better? Wait until the
+ % problem manifests itself, so it can be fixed for real --karl.
+ }%
+ }%
+ %
+ \parsearg\domultitable
+}
+\def\domultitable#1{%
+ % To parse everything between @multitable and @item:
+ \setuptable#1 \endsetuptable
+ %
+ % This preamble sets up a generic column definition, which will
+ % be used as many times as user calls for columns.
+ % \vtop will set a single line and will also let text wrap and
+ % continue for many paragraphs if desired.
+ \halign\bgroup &%
+ \global\advance\colcount by 1
+ \multistrut
+ \vtop{%
+ % Use the current \colcount to find the correct column width:
+ \hsize=\expandafter\csname col\the\colcount\endcsname
+ %
+ % In order to keep entries from bumping into each other
+ % we will add a \leftskip of \multitablecolspace to all columns after
+ % the first one.
+ %
+ % If a template has been used, we will add \multitablecolspace
+ % to the width of each template entry.
+ %
+ % If the user has set preamble in terms of percent of \hsize we will
+ % use that dimension as the width of the column, and the \leftskip
+ % will keep entries from bumping into each other. Table will start at
+ % left margin and final column will justify at right margin.
+ %
+ % Make sure we don't inherit \rightskip from the outer environment.
+ \rightskip=0pt
+ \ifnum\colcount=1
+ % The first column will be indented with the surrounding text.
+ \advance\hsize by\leftskip
+ \else
+ \ifsetpercent \else
+ % If user has not set preamble in terms of percent of \hsize
+ % we will advance \hsize by \multitablecolspace.
+ \advance\hsize by \multitablecolspace
+ \fi
+ % In either case we will make \leftskip=\multitablecolspace:
+ \leftskip=\multitablecolspace
+ \fi
+ % Ignoring space at the beginning and end avoids an occasional spurious
+ % blank line, when TeX decides to break the line at the space before the
+ % box from the multistrut, so the strut ends up on a line by itself.
+ % For example:
+ % @multitable @columnfractions .11 .89
+ % @item @code{#}
+ % @tab Legal holiday which is valid in major parts of the whole country.
+ % Is automatically provided with highlighting sequences respectively
+ % marking characters.
+ \noindent\ignorespaces##\unskip\multistrut
+ }\cr
+}
+\def\Emultitable{%
+ \crcr
+ \egroup % end the \halign
+ \global\setpercentfalse
+}
+
+\def\setmultitablespacing{%
+ \def\multistrut{\strut}% just use the standard line spacing
+ %
+ % Compute \multitablelinespace (if not defined by user) for use in
+ % \multitableparskip calculation. We used define \multistrut based on
+ % this, but (ironically) that caused the spacing to be off.
+ % See bug-texinfo report from Werner Lemberg, 31 Oct 2004 12:52:20 +0100.
+\ifdim\multitablelinespace=0pt
+\setbox0=\vbox{X}\global\multitablelinespace=\the\baselineskip
+\global\advance\multitablelinespace by-\ht0
+\fi
+%% Test to see if parskip is larger than space between lines of
+%% table. If not, do nothing.
+%% If so, set to same dimension as multitablelinespace.
+\ifdim\multitableparskip>\multitablelinespace
+\global\multitableparskip=\multitablelinespace
+\global\advance\multitableparskip-7pt %% to keep parskip somewhat smaller
+ %% than skip between lines in the table.
+\fi%
+\ifdim\multitableparskip=0pt
+\global\multitableparskip=\multitablelinespace
+\global\advance\multitableparskip-7pt %% to keep parskip somewhat smaller
+ %% than skip between lines in the table.
+\fi}
+
+
+\message{conditionals,}
+
+% @iftex, @ifnotdocbook, @ifnothtml, @ifnotinfo, @ifnotplaintext,
+% @ifnotxml always succeed. They currently do nothing; we don't
+% attempt to check whether the conditionals are properly nested. But we
+% have to remember that they are conditionals, so that @end doesn't
+% attempt to close an environment group.
+%
+\def\makecond#1{%
+ \expandafter\let\csname #1\endcsname = \relax
+ \expandafter\let\csname iscond.#1\endcsname = 1
+}
+\makecond{iftex}
+\makecond{ifnotdocbook}
+\makecond{ifnothtml}
+\makecond{ifnotinfo}
+\makecond{ifnotplaintext}
+\makecond{ifnotxml}
+
+% Ignore @ignore, @ifhtml, @ifinfo, and the like.
+%
+\def\direntry{\doignore{direntry}}
+\def\documentdescription{\doignore{documentdescription}}
+\def\docbook{\doignore{docbook}}
+\def\html{\doignore{html}}
+\def\ifdocbook{\doignore{ifdocbook}}
+\def\ifhtml{\doignore{ifhtml}}
+\def\ifinfo{\doignore{ifinfo}}
+\def\ifnottex{\doignore{ifnottex}}
+\def\ifplaintext{\doignore{ifplaintext}}
+\def\ifxml{\doignore{ifxml}}
+\def\ignore{\doignore{ignore}}
+\def\menu{\doignore{menu}}
+\def\xml{\doignore{xml}}
+
+% Ignore text until a line `@end #1', keeping track of nested conditionals.
+%
+% A count to remember the depth of nesting.
+\newcount\doignorecount
+
+\def\doignore#1{\begingroup
+ % Scan in ``verbatim'' mode:
+ \obeylines
+ \catcode`\@ = \other
+ \catcode`\{ = \other
+ \catcode`\} = \other
+ %
+ % Make sure that spaces turn into tokens that match what \doignoretext wants.
+ \spaceisspace
+ %
+ % Count number of #1's that we've seen.
+ \doignorecount = 0
+ %
+ % Swallow text until we reach the matching `@end #1'.
+ \dodoignore{#1}%
+}
+
+{ \catcode`_=11 % We want to use \_STOP_ which cannot appear in texinfo source.
+ \obeylines %
+ %
+ \gdef\dodoignore#1{%
+ % #1 contains the command name as a string, e.g., `ifinfo'.
+ %
+ % Define a command to find the next `@end #1'.
+ \long\def\doignoretext##1^^M@end #1{%
+ \doignoretextyyy##1^^M@#1\_STOP_}%
+ %
+ % And this command to find another #1 command, at the beginning of a
+ % line. (Otherwise, we would consider a line `@c @ifset', for
+ % example, to count as an @ifset for nesting.)
+ \long\def\doignoretextyyy##1^^M@#1##2\_STOP_{\doignoreyyy{##2}\_STOP_}%
+ %
+ % And now expand that command.
+ \doignoretext ^^M%
+ }%
+}
+
+\def\doignoreyyy#1{%
+ \def\temp{#1}%
+ \ifx\temp\empty % Nothing found.
+ \let\next\doignoretextzzz
+ \else % Found a nested condition, ...
+ \advance\doignorecount by 1
+ \let\next\doignoretextyyy % ..., look for another.
+ % If we're here, #1 ends with ^^M\ifinfo (for example).
+ \fi
+ \next #1% the token \_STOP_ is present just after this macro.
+}
+
+% We have to swallow the remaining "\_STOP_".
+%
+\def\doignoretextzzz#1{%
+ \ifnum\doignorecount = 0 % We have just found the outermost @end.
+ \let\next\enddoignore
+ \else % Still inside a nested condition.
+ \advance\doignorecount by -1
+ \let\next\doignoretext % Look for the next @end.
+ \fi
+ \next
+}
+
+% Finish off ignored text.
+{ \obeylines%
+ % Ignore anything after the last `@end #1'; this matters in verbatim
+ % environments, where otherwise the newline after an ignored conditional
+ % would result in a blank line in the output.
+ \gdef\enddoignore#1^^M{\endgroup\ignorespaces}%
+}
+
+
+% @set VAR sets the variable VAR to an empty value.
+% @set VAR REST-OF-LINE sets VAR to the value REST-OF-LINE.
+%
+% Since we want to separate VAR from REST-OF-LINE (which might be
+% empty), we can't just use \parsearg; we have to insert a space of our
+% own to delimit the rest of the line, and then take it out again if we
+% didn't need it.
+% We rely on the fact that \parsearg sets \catcode`\ =10.
+%
+\parseargdef\set{\setyyy#1 \endsetyyy}
+\def\setyyy#1 #2\endsetyyy{%
+ {%
+ \makevalueexpandable
+ \def\temp{#2}%
+ \edef\next{\gdef\makecsname{SET#1}}%
+ \ifx\temp\empty
+ \next{}%
+ \else
+ \setzzz#2\endsetzzz
+ \fi
+ }%
+}
+% Remove the trailing space \setxxx inserted.
+\def\setzzz#1 \endsetzzz{\next{#1}}
+
+% @clear VAR clears (i.e., unsets) the variable VAR.
+%
+\parseargdef\clear{%
+ {%
+ \makevalueexpandable
+ \global\expandafter\let\csname SET#1\endcsname=\relax
+ }%
+}
+
+% @value{foo} gets the text saved in variable foo.
+\def\value{\begingroup\makevalueexpandable\valuexxx}
+\def\valuexxx#1{\expandablevalue{#1}\endgroup}
+{
+ \catcode`\- = \active \catcode`\_ = \active
+ %
+ \gdef\makevalueexpandable{%
+ \let\value = \expandablevalue
+ % We don't want these characters active, ...
+ \catcode`\-=\other \catcode`\_=\other
+ % ..., but we might end up with active ones in the argument if
+ % we're called from @code, as @code{@value{foo-bar_}}, though.
+ % So \let them to their normal equivalents.
+ \let-\realdash \let_\normalunderscore
+ }
+}
+
+% We have this subroutine so that we can handle at least some @value's
+% properly in indexes (we call \makevalueexpandable in \indexdummies).
+% The command has to be fully expandable (if the variable is set), since
+% the result winds up in the index file. This means that if the
+% variable's value contains other Texinfo commands, it's almost certain
+% it will fail (although perhaps we could fix that with sufficient work
+% to do a one-level expansion on the result, instead of complete).
+%
+\def\expandablevalue#1{%
+ \expandafter\ifx\csname SET#1\endcsname\relax
+ {[No value for ``#1'']}%
+ \message{Variable `#1', used in @value, is not set.}%
+ \else
+ \csname SET#1\endcsname
+ \fi
+}
+
+% @ifset VAR ... @end ifset reads the `...' iff VAR has been defined
+% with @set.
+%
+% To get special treatment of `@end ifset,' call \makeond and the redefine.
+%
+\makecond{ifset}
+\def\ifset{\parsearg{\doifset{\let\next=\ifsetfail}}}
+\def\doifset#1#2{%
+ {%
+ \makevalueexpandable
+ \let\next=\empty
+ \expandafter\ifx\csname SET#2\endcsname\relax
+ #1% If not set, redefine \next.
+ \fi
+ \expandafter
+ }\next
+}
+\def\ifsetfail{\doignore{ifset}}
+
+% @ifclear VAR ... @end ifclear reads the `...' iff VAR has never been
+% defined with @set, or has been undefined with @clear.
+%
+% The `\else' inside the `\doifset' parameter is a trick to reuse the
+% above code: if the variable is not set, do nothing, if it is set,
+% then redefine \next to \ifclearfail.
+%
+\makecond{ifclear}
+\def\ifclear{\parsearg{\doifset{\else \let\next=\ifclearfail}}}
+\def\ifclearfail{\doignore{ifclear}}
+
+% @dircategory CATEGORY -- specify a category of the dir file
+% which this file should belong to. Ignore this in TeX.
+\let\dircategory=\comment
+
+% @defininfoenclose.
+\let\definfoenclose=\comment
+
+
+\message{indexing,}
+% Index generation facilities
+
+% Define \newwrite to be identical to plain tex's \newwrite
+% except not \outer, so it can be used within macros and \if's.
+\edef\newwrite{\makecsname{ptexnewwrite}}
+
+% \newindex {foo} defines an index named foo.
+% It automatically defines \fooindex such that
+% \fooindex ...rest of line... puts an entry in the index foo.
+% It also defines \fooindfile to be the number of the output channel for
+% the file that accumulates this index. The file's extension is foo.
+% The name of an index should be no more than 2 characters long
+% for the sake of vms.
+%
+\def\newindex#1{%
+ \iflinks
+ \expandafter\newwrite \csname#1indfile\endcsname
+ \openout \csname#1indfile\endcsname \jobname.#1 % Open the file
+ \fi
+ \expandafter\xdef\csname#1index\endcsname{% % Define @#1index
+ \noexpand\doindex{#1}}
+}
+
+% @defindex foo == \newindex{foo}
+%
+\def\defindex{\parsearg\newindex}
+
+% Define @defcodeindex, like @defindex except put all entries in @code.
+%
+\def\defcodeindex{\parsearg\newcodeindex}
+%
+\def\newcodeindex#1{%
+ \iflinks
+ \expandafter\newwrite \csname#1indfile\endcsname
+ \openout \csname#1indfile\endcsname \jobname.#1
+ \fi
+ \expandafter\xdef\csname#1index\endcsname{%
+ \noexpand\docodeindex{#1}}%
+}
+
+
+% @synindex foo bar makes index foo feed into index bar.
+% Do this instead of @defindex foo if you don't want it as a separate index.
+%
+% @syncodeindex foo bar similar, but put all entries made for index foo
+% inside @code.
+%
+\def\synindex#1 #2 {\dosynindex\doindex{#1}{#2}}
+\def\syncodeindex#1 #2 {\dosynindex\docodeindex{#1}{#2}}
+
+% #1 is \doindex or \docodeindex, #2 the index getting redefined (foo),
+% #3 the target index (bar).
+\def\dosynindex#1#2#3{%
+ % Only do \closeout if we haven't already done it, else we'll end up
+ % closing the target index.
+ \expandafter \ifx\csname donesynindex#2\endcsname \undefined
+ % The \closeout helps reduce unnecessary open files; the limit on the
+ % Acorn RISC OS is a mere 16 files.
+ \expandafter\closeout\csname#2indfile\endcsname
+ \expandafter\let\csname\donesynindex#2\endcsname = 1
+ \fi
+ % redefine \fooindfile:
+ \expandafter\let\expandafter\temp\expandafter=\csname#3indfile\endcsname
+ \expandafter\let\csname#2indfile\endcsname=\temp
+ % redefine \fooindex:
+ \expandafter\xdef\csname#2index\endcsname{\noexpand#1{#3}}%
+}
+
+% Define \doindex, the driver for all \fooindex macros.
+% Argument #1 is generated by the calling \fooindex macro,
+% and it is "foo", the name of the index.
+
+% \doindex just uses \parsearg; it calls \doind for the actual work.
+% This is because \doind is more useful to call from other macros.
+
+% There is also \dosubind {index}{topic}{subtopic}
+% which makes an entry in a two-level index such as the operation index.
+
+\def\doindex#1{\edef\indexname{#1}\parsearg\singleindexer}
+\def\singleindexer #1{\doind{\indexname}{#1}}
+
+% like the previous two, but they put @code around the argument.
+\def\docodeindex#1{\edef\indexname{#1}\parsearg\singlecodeindexer}
+\def\singlecodeindexer #1{\doind{\indexname}{\code{#1}}}
+
+% Take care of Texinfo commands that can appear in an index entry.
+% Since there are some commands we want to expand, and others we don't,
+% we have to laboriously prevent expansion for those that we don't.
+%
+\def\indexdummies{%
+ \escapechar = `\\ % use backslash in output files.
+ \def\@{@}% change to @@ when we switch to @ as escape char in index files.
+ \def\ {\realbackslash\space }%
+ %
+ % Need these in case \tex is in effect and \{ is a \delimiter again.
+ % But can't use \lbracecmd and \rbracecmd because texindex assumes
+ % braces and backslashes are used only as delimiters.
+ \let\{ = \mylbrace
+ \let\} = \myrbrace
+ %
+ % I don't entirely understand this, but when an index entry is
+ % generated from a macro call, the \endinput which \scanmacro inserts
+ % causes processing to be prematurely terminated. This is,
+ % apparently, because \indexsorttmp is fully expanded, and \endinput
+ % is an expandable command. The redefinition below makes \endinput
+ % disappear altogether for that purpose -- although logging shows that
+ % processing continues to some further point. On the other hand, it
+ % seems \endinput does not hurt in the printed index arg, since that
+ % is still getting written without apparent harm.
+ %
+ % Sample source (mac-idx3.tex, reported by Graham Percival to
+ % help-texinfo, 22may06):
+ % @macro funindex {WORD}
+ % @findex xyz
+ % @end macro
+ % ...
+ % @funindex commtest
+ %
+ % The above is not enough to reproduce the bug, but it gives the flavor.
+ %
+ % Sample whatsit resulting:
+ % .@write3{\entry{xyz}{@folio }{@code {xyz@endinput }}}
+ %
+ % So:
+ \let\endinput = \empty
+ %
+ % Do the redefinitions.
+ \commondummies
+}
+
+% For the aux and toc files, @ is the escape character. So we want to
+% redefine everything using @ as the escape character (instead of
+% \realbackslash, still used for index files). When everything uses @,
+% this will be simpler.
+%
+\def\atdummies{%
+ \def\@{@@}%
+ \def\ {@ }%
+ \let\{ = \lbraceatcmd
+ \let\} = \rbraceatcmd
+ %
+ % Do the redefinitions.
+ \commondummies
+ \otherbackslash
+}
+
+% Called from \indexdummies and \atdummies.
+%
+\def\commondummies{%
+ %
+ % \definedummyword defines \#1 as \string\#1\space, thus effectively
+ % preventing its expansion. This is used only for control% words,
+ % not control letters, because the \space would be incorrect for
+ % control characters, but is needed to separate the control word
+ % from whatever follows.
+ %
+ % For control letters, we have \definedummyletter, which omits the
+ % space.
+ %
+ % These can be used both for control words that take an argument and
+ % those that do not. If it is followed by {arg} in the input, then
+ % that will dutifully get written to the index (or wherever).
+ %
+ \def\definedummyword ##1{\def##1{\string##1\space}}%
+ \def\definedummyletter##1{\def##1{\string##1}}%
+ \let\definedummyaccent\definedummyletter
+ %
+ \commondummiesnofonts
+ %
+ \definedummyletter\_%
+ %
+ % Non-English letters.
+ \definedummyword\AA
+ \definedummyword\AE
+ \definedummyword\L
+ \definedummyword\OE
+ \definedummyword\O
+ \definedummyword\aa
+ \definedummyword\ae
+ \definedummyword\l
+ \definedummyword\oe
+ \definedummyword\o
+ \definedummyword\ss
+ \definedummyword\exclamdown
+ \definedummyword\questiondown
+ \definedummyword\ordf
+ \definedummyword\ordm
+ %
+ % Although these internal commands shouldn't show up, sometimes they do.
+ \definedummyword\bf
+ \definedummyword\gtr
+ \definedummyword\hat
+ \definedummyword\less
+ \definedummyword\sf
+ \definedummyword\sl
+ \definedummyword\tclose
+ \definedummyword\tt
+ %
+ \definedummyword\LaTeX
+ \definedummyword\TeX
+ %
+ % Assorted special characters.
+ \definedummyword\bullet
+ \definedummyword\comma
+ \definedummyword\copyright
+ \definedummyword\registeredsymbol
+ \definedummyword\dots
+ \definedummyword\enddots
+ \definedummyword\equiv
+ \definedummyword\error
+ \definedummyword\euro
+ \definedummyword\guillemetleft
+ \definedummyword\guillemetright
+ \definedummyword\guilsinglleft
+ \definedummyword\guilsinglright
+ \definedummyword\expansion
+ \definedummyword\minus
+ \definedummyword\pounds
+ \definedummyword\point
+ \definedummyword\print
+ \definedummyword\quotedblbase
+ \definedummyword\quotedblleft
+ \definedummyword\quotedblright
+ \definedummyword\quoteleft
+ \definedummyword\quoteright
+ \definedummyword\quotesinglbase
+ \definedummyword\result
+ \definedummyword\textdegree
+ %
+ % We want to disable all macros so that they are not expanded by \write.
+ \macrolist
+ %
+ \normalturnoffactive
+ %
+ % Handle some cases of @value -- where it does not contain any
+ % (non-fully-expandable) commands.
+ \makevalueexpandable
+}
+
+% \commondummiesnofonts: common to \commondummies and \indexnofonts.
+%
+\def\commondummiesnofonts{%
+ % Control letters and accents.
+ \definedummyletter\!%
+ \definedummyaccent\"%
+ \definedummyaccent\'%
+ \definedummyletter\*%
+ \definedummyaccent\,%
+ \definedummyletter\.%
+ \definedummyletter\/%
+ \definedummyletter\:%
+ \definedummyaccent\=%
+ \definedummyletter\?%
+ \definedummyaccent\^%
+ \definedummyaccent\`%
+ \definedummyaccent\~%
+ \definedummyword\u
+ \definedummyword\v
+ \definedummyword\H
+ \definedummyword\dotaccent
+ \definedummyword\ringaccent
+ \definedummyword\tieaccent
+ \definedummyword\ubaraccent
+ \definedummyword\udotaccent
+ \definedummyword\dotless
+ %
+ % Texinfo font commands.
+ \definedummyword\b
+ \definedummyword\i
+ \definedummyword\r
+ \definedummyword\sc
+ \definedummyword\t
+ %
+ % Commands that take arguments.
+ \definedummyword\acronym
+ \definedummyword\cite
+ \definedummyword\code
+ \definedummyword\command
+ \definedummyword\dfn
+ \definedummyword\emph
+ \definedummyword\env
+ \definedummyword\file
+ \definedummyword\kbd
+ \definedummyword\key
+ \definedummyword\math
+ \definedummyword\option
+ \definedummyword\pxref
+ \definedummyword\ref
+ \definedummyword\samp
+ \definedummyword\strong
+ \definedummyword\tie
+ \definedummyword\uref
+ \definedummyword\url
+ \definedummyword\var
+ \definedummyword\verb
+ \definedummyword\w
+ \definedummyword\xref
+}
+
+% \indexnofonts is used when outputting the strings to sort the index
+% by, and when constructing control sequence names. It eliminates all
+% control sequences and just writes whatever the best ASCII sort string
+% would be for a given command (usually its argument).
+%
+\def\indexnofonts{%
+ % Accent commands should become @asis.
+ \def\definedummyaccent##1{\let##1\asis}%
+ % We can just ignore other control letters.
+ \def\definedummyletter##1{\let##1\empty}%
+ % Hopefully, all control words can become @asis.
+ \let\definedummyword\definedummyaccent
+ %
+ \commondummiesnofonts
+ %
+ % Don't no-op \tt, since it isn't a user-level command
+ % and is used in the definitions of the active chars like <, >, |, etc.
+ % Likewise with the other plain tex font commands.
+ %\let\tt=\asis
+ %
+ \def\ { }%
+ \def\@{@}%
+ % how to handle braces?
+ \def\_{\normalunderscore}%
+ %
+ % Non-English letters.
+ \def\AA{AA}%
+ \def\AE{AE}%
+ \def\L{L}%
+ \def\OE{OE}%
+ \def\O{O}%
+ \def\aa{aa}%
+ \def\ae{ae}%
+ \def\l{l}%
+ \def\oe{oe}%
+ \def\o{o}%
+ \def\ss{ss}%
+ \def\exclamdown{!}%
+ \def\questiondown{?}%
+ \def\ordf{a}%
+ \def\ordm{o}%
+ %
+ \def\LaTeX{LaTeX}%
+ \def\TeX{TeX}%
+ %
+ % Assorted special characters.
+ % (The following {} will end up in the sort string, but that's ok.)
+ \def\bullet{bullet}%
+ \def\comma{,}%
+ \def\copyright{copyright}%
+ \def\registeredsymbol{R}%
+ \def\dots{...}%
+ \def\enddots{...}%
+ \def\equiv{==}%
+ \def\error{error}%
+ \def\euro{euro}%
+ \def\guillemetleft{<<}%
+ \def\guillemetright{>>}%
+ \def\guilsinglleft{<}%
+ \def\guilsinglright{>}%
+ \def\expansion{==>}%
+ \def\minus{-}%
+ \def\pounds{pounds}%
+ \def\point{.}%
+ \def\print{-|}%
+ \def\quotedblbase{"}%
+ \def\quotedblleft{"}%
+ \def\quotedblright{"}%
+ \def\quoteleft{`}%
+ \def\quoteright{'}%
+ \def\quotesinglbase{,}%
+ \def\result{=>}%
+ \def\textdegree{degrees}%
+ %
+ % We need to get rid of all macros, leaving only the arguments (if present).
+ % Of course this is not nearly correct, but it is the best we can do for now.
+ % makeinfo does not expand macros in the argument to @deffn, which ends up
+ % writing an index entry, and texindex isn't prepared for an index sort entry
+ % that starts with \.
+ %
+ % Since macro invocations are followed by braces, we can just redefine them
+ % to take a single TeX argument. The case of a macro invocation that
+ % goes to end-of-line is not handled.
+ %
+ \macrolist
+}
+
+\let\indexbackslash=0 %overridden during \printindex.
+\let\SETmarginindex=\relax % put index entries in margin (undocumented)?
+
+% Most index entries go through here, but \dosubind is the general case.
+% #1 is the index name, #2 is the entry text.
+\def\doind#1#2{\dosubind{#1}{#2}{}}
+
+% Workhorse for all \fooindexes.
+% #1 is name of index, #2 is stuff to put there, #3 is subentry --
+% empty if called from \doind, as we usually are (the main exception
+% is with most defuns, which call us directly).
+%
+\def\dosubind#1#2#3{%
+ \iflinks
+ {%
+ % Store the main index entry text (including the third arg).
+ \toks0 = {#2}%
+ % If third arg is present, precede it with a space.
+ \def\thirdarg{#3}%
+ \ifx\thirdarg\empty \else
+ \toks0 = \expandafter{\the\toks0 \space #3}%
+ \fi
+ %
+ \edef\writeto{\csname#1indfile\endcsname}%
+ %
+ \safewhatsit\dosubindwrite
+ }%
+ \fi
+}
+
+% Write the entry in \toks0 to the index file:
+%
+\def\dosubindwrite{%
+ % Put the index entry in the margin if desired.
+ \ifx\SETmarginindex\relax\else
+ \insert\margin{\hbox{\vrule height8pt depth3pt width0pt \the\toks0}}%
+ \fi
+ %
+ % Remember, we are within a group.
+ \indexdummies % Must do this here, since \bf, etc expand at this stage
+ \def\backslashcurfont{\indexbackslash}% \indexbackslash isn't defined now
+ % so it will be output as is; and it will print as backslash.
+ %
+ % Process the index entry with all font commands turned off, to
+ % get the string to sort by.
+ {\indexnofonts
+ \edef\temp{\the\toks0}% need full expansion
+ \xdef\indexsorttmp{\temp}%
+ }%
+ %
+ % Set up the complete index entry, with both the sort key and
+ % the original text, including any font commands. We write
+ % three arguments to \entry to the .?? file (four in the
+ % subentry case), texindex reduces to two when writing the .??s
+ % sorted result.
+ \edef\temp{%
+ \write\writeto{%
+ \string\entry{\indexsorttmp}{\noexpand\folio}{\the\toks0}}%
+ }%
+ \temp
+}
+
+% Take care of unwanted page breaks/skips around a whatsit:
+%
+% If a skip is the last thing on the list now, preserve it
+% by backing up by \lastskip, doing the \write, then inserting
+% the skip again. Otherwise, the whatsit generated by the
+% \write or \pdfdest will make \lastskip zero. The result is that
+% sequences like this:
+% @end defun
+% @tindex whatever
+% @defun ...
+% will have extra space inserted, because the \medbreak in the
+% start of the @defun won't see the skip inserted by the @end of
+% the previous defun.
+%
+% But don't do any of this if we're not in vertical mode. We
+% don't want to do a \vskip and prematurely end a paragraph.
+%
+% Avoid page breaks due to these extra skips, too.
+%
+% But wait, there is a catch there:
+% We'll have to check whether \lastskip is zero skip. \ifdim is not
+% sufficient for this purpose, as it ignores stretch and shrink parts
+% of the skip. The only way seems to be to check the textual
+% representation of the skip.
+%
+% The following is almost like \def\zeroskipmacro{0.0pt} except that
+% the ``p'' and ``t'' characters have catcode \other, not 11 (letter).
+%
+\edef\zeroskipmacro{\expandafter\the\csname z@skip\endcsname}
+%
+\newskip\whatsitskip
+\newcount\whatsitpenalty
+%
+% ..., ready, GO:
+%
+\def\safewhatsit#1{%
+\ifhmode
+ #1%
+\else
+ % \lastskip and \lastpenalty cannot both be nonzero simultaneously.
+ \whatsitskip = \lastskip
+ \edef\lastskipmacro{\the\lastskip}%
+ \whatsitpenalty = \lastpenalty
+ %
+ % If \lastskip is nonzero, that means the last item was a
+ % skip. And since a skip is discardable, that means this
+ % -\whatsitskip glue we're inserting is preceded by a
+ % non-discardable item, therefore it is not a potential
+ % breakpoint, therefore no \nobreak needed.
+ \ifx\lastskipmacro\zeroskipmacro
+ \else
+ \vskip-\whatsitskip
+ \fi
+ %
+ #1%
+ %
+ \ifx\lastskipmacro\zeroskipmacro
+ % If \lastskip was zero, perhaps the last item was a penalty, and
+ % perhaps it was >=10000, e.g., a \nobreak. In that case, we want
+ % to re-insert the same penalty (values >10000 are used for various
+ % signals); since we just inserted a non-discardable item, any
+ % following glue (such as a \parskip) would be a breakpoint. For example:
+ %
+ % @deffn deffn-whatever
+ % @vindex index-whatever
+ % Description.
+ % would allow a break between the index-whatever whatsit
+ % and the "Description." paragraph.
+ \ifnum\whatsitpenalty>9999 \penalty\whatsitpenalty \fi
+ \else
+ % On the other hand, if we had a nonzero \lastskip,
+ % this make-up glue would be preceded by a non-discardable item
+ % (the whatsit from the \write), so we must insert a \nobreak.
+ \nobreak\vskip\whatsitskip
+ \fi
+\fi
+}
+
+% The index entry written in the file actually looks like
+% \entry {sortstring}{page}{topic}
+% or
+% \entry {sortstring}{page}{topic}{subtopic}
+% The texindex program reads in these files and writes files
+% containing these kinds of lines:
+% \initial {c}
+% before the first topic whose initial is c
+% \entry {topic}{pagelist}
+% for a topic that is used without subtopics
+% \primary {topic}
+% for the beginning of a topic that is used with subtopics
+% \secondary {subtopic}{pagelist}
+% for each subtopic.
+
+% Define the user-accessible indexing commands
+% @findex, @vindex, @kindex, @cindex.
+
+\def\findex {\fnindex}
+\def\kindex {\kyindex}
+\def\cindex {\cpindex}
+\def\vindex {\vrindex}
+\def\tindex {\tpindex}
+\def\pindex {\pgindex}
+
+\def\cindexsub {\begingroup\obeylines\cindexsub}
+{\obeylines %
+\gdef\cindexsub "#1" #2^^M{\endgroup %
+\dosubind{cp}{#2}{#1}}}
+
+% Define the macros used in formatting output of the sorted index material.
+
+% @printindex causes a particular index (the ??s file) to get printed.
+% It does not print any chapter heading (usually an @unnumbered).
+%
+\parseargdef\printindex{\begingroup
+ \dobreak \chapheadingskip{10000}%
+ %
+ \smallfonts \rm
+ \tolerance = 9500
+ \plainfrenchspacing
+ \everypar = {}% don't want the \kern\-parindent from indentation suppression.
+ %
+ % See if the index file exists and is nonempty.
+ % Change catcode of @ here so that if the index file contains
+ % \initial {@}
+ % as its first line, TeX doesn't complain about mismatched braces
+ % (because it thinks @} is a control sequence).
+ \catcode`\@ = 11
+ \openin 1 \jobname.#1s
+ \ifeof 1
+ % \enddoublecolumns gets confused if there is no text in the index,
+ % and it loses the chapter title and the aux file entries for the
+ % index. The easiest way to prevent this problem is to make sure
+ % there is some text.
+ \putwordIndexNonexistent
+ \else
+ %
+ % If the index file exists but is empty, then \openin leaves \ifeof
+ % false. We have to make TeX try to read something from the file, so
+ % it can discover if there is anything in it.
+ \read 1 to \temp
+ \ifeof 1
+ \putwordIndexIsEmpty
+ \else
+ % Index files are almost Texinfo source, but we use \ as the escape
+ % character. It would be better to use @, but that's too big a change
+ % to make right now.
+ \def\indexbackslash{\backslashcurfont}%
+ \catcode`\\ = 0
+ \escapechar = `\\
+ \begindoublecolumns
+ \input \jobname.#1s
+ \enddoublecolumns
+ \fi
+ \fi
+ \closein 1
+\endgroup}
+
+% These macros are used by the sorted index file itself.
+% Change them to control the appearance of the index.
+
+\def\initial#1{{%
+ % Some minor font changes for the special characters.
+ \let\tentt=\sectt \let\tt=\sectt \let\sf=\sectt
+ %
+ % Remove any glue we may have, we'll be inserting our own.
+ \removelastskip
+ %
+ % We like breaks before the index initials, so insert a bonus.
+ \nobreak
+ \vskip 0pt plus 3\baselineskip
+ \penalty 0
+ \vskip 0pt plus -3\baselineskip
+ %
+ % Typeset the initial. Making this add up to a whole number of
+ % baselineskips increases the chance of the dots lining up from column
+ % to column. It still won't often be perfect, because of the stretch
+ % we need before each entry, but it's better.
+ %
+ % No shrink because it confuses \balancecolumns.
+ \vskip 1.67\baselineskip plus .5\baselineskip
+ \leftline{\secbf #1}%
+ % Do our best not to break after the initial.
+ \nobreak
+ \vskip .33\baselineskip plus .1\baselineskip
+}}
+
+% \entry typesets a paragraph consisting of the text (#1), dot leaders, and
+% then page number (#2) flushed to the right margin. It is used for index
+% and table of contents entries. The paragraph is indented by \leftskip.
+%
+% A straightforward implementation would start like this:
+% \def\entry#1#2{...
+% But this frozes the catcodes in the argument, and can cause problems to
+% @code, which sets - active. This problem was fixed by a kludge---
+% ``-'' was active throughout whole index, but this isn't really right.
+%
+% The right solution is to prevent \entry from swallowing the whole text.
+% --kasal, 21nov03
+\def\entry{%
+ \begingroup
+ %
+ % Start a new paragraph if necessary, so our assignments below can't
+ % affect previous text.
+ \par
+ %
+ % Do not fill out the last line with white space.
+ \parfillskip = 0in
+ %
+ % No extra space above this paragraph.
+ \parskip = 0in
+ %
+ % Do not prefer a separate line ending with a hyphen to fewer lines.
+ \finalhyphendemerits = 0
+ %
+ % \hangindent is only relevant when the entry text and page number
+ % don't both fit on one line. In that case, bob suggests starting the
+ % dots pretty far over on the line. Unfortunately, a large
+ % indentation looks wrong when the entry text itself is broken across
+ % lines. So we use a small indentation and put up with long leaders.
+ %
+ % \hangafter is reset to 1 (which is the value we want) at the start
+ % of each paragraph, so we need not do anything with that.
+ \hangindent = 2em
+ %
+ % When the entry text needs to be broken, just fill out the first line
+ % with blank space.
+ \rightskip = 0pt plus1fil
+ %
+ % A bit of stretch before each entry for the benefit of balancing
+ % columns.
+ \vskip 0pt plus1pt
+ %
+ % Swallow the left brace of the text (first parameter):
+ \afterassignment\doentry
+ \let\temp =
+}
+\def\doentry{%
+ \bgroup % Instead of the swallowed brace.
+ \noindent
+ \aftergroup\finishentry
+ % And now comes the text of the entry.
+}
+\def\finishentry#1{%
+ % #1 is the page number.
+ %
+ % The following is kludged to not output a line of dots in the index if
+ % there are no page numbers. The next person who breaks this will be
+ % cursed by a Unix daemon.
+ \setbox\boxA = \hbox{#1}%
+ \ifdim\wd\boxA = 0pt
+ \ %
+ \else
+ %
+ % If we must, put the page number on a line of its own, and fill out
+ % this line with blank space. (The \hfil is overwhelmed with the
+ % fill leaders glue in \indexdotfill if the page number does fit.)
+ \hfil\penalty50
+ \null\nobreak\indexdotfill % Have leaders before the page number.
+ %
+ % The `\ ' here is removed by the implicit \unskip that TeX does as
+ % part of (the primitive) \par. Without it, a spurious underfull
+ % \hbox ensues.
+ \ifpdf
+ \pdfgettoks#1.%
+ \ \the\toksA
+ \else
+ \ #1%
+ \fi
+ \fi
+ \par
+ \endgroup
+}
+
+% Like plain.tex's \dotfill, except uses up at least 1 em.
+\def\indexdotfill{\cleaders
+ \hbox{$\mathsurround=0pt \mkern1.5mu.\mkern1.5mu$}\hskip 1em plus 1fill}
+
+\def\primary #1{\line{#1\hfil}}
+
+\newskip\secondaryindent \secondaryindent=0.5cm
+\def\secondary#1#2{{%
+ \parfillskip=0in
+ \parskip=0in
+ \hangindent=1in
+ \hangafter=1
+ \noindent\hskip\secondaryindent\hbox{#1}\indexdotfill
+ \ifpdf
+ \pdfgettoks#2.\ \the\toksA % The page number ends the paragraph.
+ \else
+ #2
+ \fi
+ \par
+}}
+
+% Define two-column mode, which we use to typeset indexes.
+% Adapted from the TeXbook, page 416, which is to say,
+% the manmac.tex format used to print the TeXbook itself.
+\catcode`\@=11
+
+\newbox\partialpage
+\newdimen\doublecolumnhsize
+
+\def\begindoublecolumns{\begingroup % ended by \enddoublecolumns
+ % Grab any single-column material above us.
+ \output = {%
+ %
+ % Here is a possibility not foreseen in manmac: if we accumulate a
+ % whole lot of material, we might end up calling this \output
+ % routine twice in a row (see the doublecol-lose test, which is
+ % essentially a couple of indexes with @setchapternewpage off). In
+ % that case we just ship out what is in \partialpage with the normal
+ % output routine. Generally, \partialpage will be empty when this
+ % runs and this will be a no-op. See the indexspread.tex test case.
+ \ifvoid\partialpage \else
+ \onepageout{\pagecontents\partialpage}%
+ \fi
+ %
+ \global\setbox\partialpage = \vbox{%
+ % Unvbox the main output page.
+ \unvbox\PAGE
+ \kern-\topskip \kern\baselineskip
+ }%
+ }%
+ \eject % run that output routine to set \partialpage
+ %
+ % Use the double-column output routine for subsequent pages.
+ \output = {\doublecolumnout}%
+ %
+ % Change the page size parameters. We could do this once outside this
+ % routine, in each of @smallbook, @afourpaper, and the default 8.5x11
+ % format, but then we repeat the same computation. Repeating a couple
+ % of assignments once per index is clearly meaningless for the
+ % execution time, so we may as well do it in one place.
+ %
+ % First we halve the line length, less a little for the gutter between
+ % the columns. We compute the gutter based on the line length, so it
+ % changes automatically with the paper format. The magic constant
+ % below is chosen so that the gutter has the same value (well, +-<1pt)
+ % as it did when we hard-coded it.
+ %
+ % We put the result in a separate register, \doublecolumhsize, so we
+ % can restore it in \pagesofar, after \hsize itself has (potentially)
+ % been clobbered.
+ %
+ \doublecolumnhsize = \hsize
+ \advance\doublecolumnhsize by -.04154\hsize
+ \divide\doublecolumnhsize by 2
+ \hsize = \doublecolumnhsize
+ %
+ % Double the \vsize as well. (We don't need a separate register here,
+ % since nobody clobbers \vsize.)
+ \vsize = 2\vsize
+}
+
+% The double-column output routine for all double-column pages except
+% the last.
+%
+\def\doublecolumnout{%
+ \splittopskip=\topskip \splitmaxdepth=\maxdepth
+ % Get the available space for the double columns -- the normal
+ % (undoubled) page height minus any material left over from the
+ % previous page.
+ \dimen@ = \vsize
+ \divide\dimen@ by 2
+ \advance\dimen@ by -\ht\partialpage
+ %
+ % box0 will be the left-hand column, box2 the right.
+ \setbox0=\vsplit255 to\dimen@ \setbox2=\vsplit255 to\dimen@
+ \onepageout\pagesofar
+ \unvbox255
+ \penalty\outputpenalty
+}
+%
+% Re-output the contents of the output page -- any previous material,
+% followed by the two boxes we just split, in box0 and box2.
+\def\pagesofar{%
+ \unvbox\partialpage
+ %
+ \hsize = \doublecolumnhsize
+ \wd0=\hsize \wd2=\hsize
+ \hbox to\pagewidth{\box0\hfil\box2}%
+}
+%
+% All done with double columns.
+\def\enddoublecolumns{%
+ % The following penalty ensures that the page builder is exercised
+ % _before_ we change the output routine. This is necessary in the
+ % following situation:
+ %
+ % The last section of the index consists only of a single entry.
+ % Before this section, \pagetotal is less than \pagegoal, so no
+ % break occurs before the last section starts. However, the last
+ % section, consisting of \initial and the single \entry, does not
+ % fit on the page and has to be broken off. Without the following
+ % penalty the page builder will not be exercised until \eject
+ % below, and by that time we'll already have changed the output
+ % routine to the \balancecolumns version, so the next-to-last
+ % double-column page will be processed with \balancecolumns, which
+ % is wrong: The two columns will go to the main vertical list, with
+ % the broken-off section in the recent contributions. As soon as
+ % the output routine finishes, TeX starts reconsidering the page
+ % break. The two columns and the broken-off section both fit on the
+ % page, because the two columns now take up only half of the page
+ % goal. When TeX sees \eject from below which follows the final
+ % section, it invokes the new output routine that we've set after
+ % \balancecolumns below; \onepageout will try to fit the two columns
+ % and the final section into the vbox of \pageheight (see
+ % \pagebody), causing an overfull box.
+ %
+ % Note that glue won't work here, because glue does not exercise the
+ % page builder, unlike penalties (see The TeXbook, pp. 280-281).
+ \penalty0
+ %
+ \output = {%
+ % Split the last of the double-column material. Leave it on the
+ % current page, no automatic page break.
+ \balancecolumns
+ %
+ % If we end up splitting too much material for the current page,
+ % though, there will be another page break right after this \output
+ % invocation ends. Having called \balancecolumns once, we do not
+ % want to call it again. Therefore, reset \output to its normal
+ % definition right away. (We hope \balancecolumns will never be
+ % called on to balance too much material, but if it is, this makes
+ % the output somewhat more palatable.)
+ \global\output = {\onepageout{\pagecontents\PAGE}}%
+ }%
+ \eject
+ \endgroup % started in \begindoublecolumns
+ %
+ % \pagegoal was set to the doubled \vsize above, since we restarted
+ % the current page. We're now back to normal single-column
+ % typesetting, so reset \pagegoal to the normal \vsize (after the
+ % \endgroup where \vsize got restored).
+ \pagegoal = \vsize
+}
+%
+% Called at the end of the double column material.
+\def\balancecolumns{%
+ \setbox0 = \vbox{\unvbox255}% like \box255 but more efficient, see p.120.
+ \dimen@ = \ht0
+ \advance\dimen@ by \topskip
+ \advance\dimen@ by-\baselineskip
+ \divide\dimen@ by 2 % target to split to
+ %debug\message{final 2-column material height=\the\ht0, target=\the\dimen@.}%
+ \splittopskip = \topskip
+ % Loop until we get a decent breakpoint.
+ {%
+ \vbadness = 10000
+ \loop
+ \global\setbox3 = \copy0
+ \global\setbox1 = \vsplit3 to \dimen@
+ \ifdim\ht3>\dimen@
+ \global\advance\dimen@ by 1pt
+ \repeat
+ }%
+ %debug\message{split to \the\dimen@, column heights: \the\ht1, \the\ht3.}%
+ \setbox0=\vbox to\dimen@{\unvbox1}%
+ \setbox2=\vbox to\dimen@{\unvbox3}%
+ %
+ \pagesofar
+}
+\catcode`\@ = \other
+
+
+\message{sectioning,}
+% Chapters, sections, etc.
+
+% \unnumberedno is an oxymoron, of course. But we count the unnumbered
+% sections so that we can refer to them unambiguously in the pdf
+% outlines by their "section number". We avoid collisions with chapter
+% numbers by starting them at 10000. (If a document ever has 10000
+% chapters, we're in trouble anyway, I'm sure.)
+\newcount\unnumberedno \unnumberedno = 10000
+\newcount\chapno
+\newcount\secno \secno=0
+\newcount\subsecno \subsecno=0
+\newcount\subsubsecno \subsubsecno=0
+
+% This counter is funny since it counts through charcodes of letters A, B, ...
+\newcount\appendixno \appendixno = `\@
+%
+% \def\appendixletter{\char\the\appendixno}
+% We do the following ugly conditional instead of the above simple
+% construct for the sake of pdftex, which needs the actual
+% letter in the expansion, not just typeset.
+%
+\def\appendixletter{%
+ \ifnum\appendixno=`A A%
+ \else\ifnum\appendixno=`B B%
+ \else\ifnum\appendixno=`C C%
+ \else\ifnum\appendixno=`D D%
+ \else\ifnum\appendixno=`E E%
+ \else\ifnum\appendixno=`F F%
+ \else\ifnum\appendixno=`G G%
+ \else\ifnum\appendixno=`H H%
+ \else\ifnum\appendixno=`I I%
+ \else\ifnum\appendixno=`J J%
+ \else\ifnum\appendixno=`K K%
+ \else\ifnum\appendixno=`L L%
+ \else\ifnum\appendixno=`M M%
+ \else\ifnum\appendixno=`N N%
+ \else\ifnum\appendixno=`O O%
+ \else\ifnum\appendixno=`P P%
+ \else\ifnum\appendixno=`Q Q%
+ \else\ifnum\appendixno=`R R%
+ \else\ifnum\appendixno=`S S%
+ \else\ifnum\appendixno=`T T%
+ \else\ifnum\appendixno=`U U%
+ \else\ifnum\appendixno=`V V%
+ \else\ifnum\appendixno=`W W%
+ \else\ifnum\appendixno=`X X%
+ \else\ifnum\appendixno=`Y Y%
+ \else\ifnum\appendixno=`Z Z%
+ % The \the is necessary, despite appearances, because \appendixletter is
+ % expanded while writing the .toc file. \char\appendixno is not
+ % expandable, thus it is written literally, thus all appendixes come out
+ % with the same letter (or @) in the toc without it.
+ \else\char\the\appendixno
+ \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi
+ \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi}
+
+% Each @chapter defines these (using marks) as the number+name, number
+% and name of the chapter. Page headings and footings can use
+% these. @section does likewise.
+\def\thischapter{}
+\def\thischapternum{}
+\def\thischaptername{}
+\def\thissection{}
+\def\thissectionnum{}
+\def\thissectionname{}
+
+\newcount\absseclevel % used to calculate proper heading level
+\newcount\secbase\secbase=0 % @raisesections/@lowersections modify this count
+
+% @raisesections: treat @section as chapter, @subsection as section, etc.
+\def\raisesections{\global\advance\secbase by -1}
+\let\up=\raisesections % original BFox name
+
+% @lowersections: treat @chapter as section, @section as subsection, etc.
+\def\lowersections{\global\advance\secbase by 1}
+\let\down=\lowersections % original BFox name
+
+% we only have subsub.
+\chardef\maxseclevel = 3
+%
+% A numbered section within an unnumbered changes to unnumbered too.
+% To achive this, remember the "biggest" unnum. sec. we are currently in:
+\chardef\unmlevel = \maxseclevel
+%
+% Trace whether the current chapter is an appendix or not:
+% \chapheadtype is "N" or "A", unnumbered chapters are ignored.
+\def\chapheadtype{N}
+
+% Choose a heading macro
+% #1 is heading type
+% #2 is heading level
+% #3 is text for heading
+\def\genhead#1#2#3{%
+ % Compute the abs. sec. level:
+ \absseclevel=#2
+ \advance\absseclevel by \secbase
+ % Make sure \absseclevel doesn't fall outside the range:
+ \ifnum \absseclevel < 0
+ \absseclevel = 0
+ \else
+ \ifnum \absseclevel > 3
+ \absseclevel = 3
+ \fi
+ \fi
+ % The heading type:
+ \def\headtype{#1}%
+ \if \headtype U%
+ \ifnum \absseclevel < \unmlevel
+ \chardef\unmlevel = \absseclevel
+ \fi
+ \else
+ % Check for appendix sections:
+ \ifnum \absseclevel = 0
+ \edef\chapheadtype{\headtype}%
+ \else
+ \if \headtype A\if \chapheadtype N%
+ \errmessage{@appendix... within a non-appendix chapter}%
+ \fi\fi
+ \fi
+ % Check for numbered within unnumbered:
+ \ifnum \absseclevel > \unmlevel
+ \def\headtype{U}%
+ \else
+ \chardef\unmlevel = 3
+ \fi
+ \fi
+ % Now print the heading:
+ \if \headtype U%
+ \ifcase\absseclevel
+ \unnumberedzzz{#3}%
+ \or \unnumberedseczzz{#3}%
+ \or \unnumberedsubseczzz{#3}%
+ \or \unnumberedsubsubseczzz{#3}%
+ \fi
+ \else
+ \if \headtype A%
+ \ifcase\absseclevel
+ \appendixzzz{#3}%
+ \or \appendixsectionzzz{#3}%
+ \or \appendixsubseczzz{#3}%
+ \or \appendixsubsubseczzz{#3}%
+ \fi
+ \else
+ \ifcase\absseclevel
+ \chapterzzz{#3}%
+ \or \seczzz{#3}%
+ \or \numberedsubseczzz{#3}%
+ \or \numberedsubsubseczzz{#3}%
+ \fi
+ \fi
+ \fi
+ \suppressfirstparagraphindent
+}
+
+% an interface:
+\def\numhead{\genhead N}
+\def\apphead{\genhead A}
+\def\unnmhead{\genhead U}
+
+% @chapter, @appendix, @unnumbered. Increment top-level counter, reset
+% all lower-level sectioning counters to zero.
+%
+% Also set \chaplevelprefix, which we prepend to @float sequence numbers
+% (e.g., figures), q.v. By default (before any chapter), that is empty.
+\let\chaplevelprefix = \empty
+%
+\outer\parseargdef\chapter{\numhead0{#1}} % normally numhead0 calls chapterzzz
+\def\chapterzzz#1{%
+ % section resetting is \global in case the chapter is in a group, such
+ % as an @include file.
+ \global\secno=0 \global\subsecno=0 \global\subsubsecno=0
+ \global\advance\chapno by 1
+ %
+ % Used for \float.
+ \gdef\chaplevelprefix{\the\chapno.}%
+ \resetallfloatnos
+ %
+ \message{\putwordChapter\space \the\chapno}%
+ %
+ % Write the actual heading.
+ \chapmacro{#1}{Ynumbered}{\the\chapno}%
+ %
+ % So @section and the like are numbered underneath this chapter.
+ \global\let\section = \numberedsec
+ \global\let\subsection = \numberedsubsec
+ \global\let\subsubsection = \numberedsubsubsec
+}
+
+\outer\parseargdef\appendix{\apphead0{#1}} % normally apphead0 calls appendixzzz
+\def\appendixzzz#1{%
+ \global\secno=0 \global\subsecno=0 \global\subsubsecno=0
+ \global\advance\appendixno by 1
+ \gdef\chaplevelprefix{\appendixletter.}%
+ \resetallfloatnos
+ %
+ \def\appendixnum{\putwordAppendix\space \appendixletter}%
+ \message{\appendixnum}%
+ %
+ \chapmacro{#1}{Yappendix}{\appendixletter}%
+ %
+ \global\let\section = \appendixsec
+ \global\let\subsection = \appendixsubsec
+ \global\let\subsubsection = \appendixsubsubsec
+}
+
+\outer\parseargdef\unnumbered{\unnmhead0{#1}} % normally unnmhead0 calls unnumberedzzz
+\def\unnumberedzzz#1{%
+ \global\secno=0 \global\subsecno=0 \global\subsubsecno=0
+ \global\advance\unnumberedno by 1
+ %
+ % Since an unnumbered has no number, no prefix for figures.
+ \global\let\chaplevelprefix = \empty
+ \resetallfloatnos
+ %
+ % This used to be simply \message{#1}, but TeX fully expands the
+ % argument to \message. Therefore, if #1 contained @-commands, TeX
+ % expanded them. For example, in `@unnumbered The @cite{Book}', TeX
+ % expanded @cite (which turns out to cause errors because \cite is meant
+ % to be executed, not expanded).
+ %
+ % Anyway, we don't want the fully-expanded definition of @cite to appear
+ % as a result of the \message, we just want `@cite' itself. We use
+ % \the<toks register> to achieve this: TeX expands \the<toks> only once,
+ % simply yielding the contents of <toks register>. (We also do this for
+ % the toc entries.)
+ \toks0 = {#1}%
+ \message{(\the\toks0)}%
+ %
+ \chapmacro{#1}{Ynothing}{\the\unnumberedno}%
+ %
+ \global\let\section = \unnumberedsec
+ \global\let\subsection = \unnumberedsubsec
+ \global\let\subsubsection = \unnumberedsubsubsec
+}
+
+% @centerchap is like @unnumbered, but the heading is centered.
+\outer\parseargdef\centerchap{%
+ % Well, we could do the following in a group, but that would break
+ % an assumption that \chapmacro is called at the outermost level.
+ % Thus we are safer this way: --kasal, 24feb04
+ \let\centerparametersmaybe = \centerparameters
+ \unnmhead0{#1}%
+ \let\centerparametersmaybe = \relax
+}
+
+% @top is like @unnumbered.
+\let\top\unnumbered
+
+% Sections.
+\outer\parseargdef\numberedsec{\numhead1{#1}} % normally calls seczzz
+\def\seczzz#1{%
+ \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1
+ \sectionheading{#1}{sec}{Ynumbered}{\the\chapno.\the\secno}%
+}
+
+\outer\parseargdef\appendixsection{\apphead1{#1}} % normally calls appendixsectionzzz
+\def\appendixsectionzzz#1{%
+ \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1
+ \sectionheading{#1}{sec}{Yappendix}{\appendixletter.\the\secno}%
+}
+\let\appendixsec\appendixsection
+
+\outer\parseargdef\unnumberedsec{\unnmhead1{#1}} % normally calls unnumberedseczzz
+\def\unnumberedseczzz#1{%
+ \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1
+ \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno.\the\secno}%
+}
+
+% Subsections.
+\outer\parseargdef\numberedsubsec{\numhead2{#1}} % normally calls numberedsubseczzz
+\def\numberedsubseczzz#1{%
+ \global\subsubsecno=0 \global\advance\subsecno by 1
+ \sectionheading{#1}{subsec}{Ynumbered}{\the\chapno.\the\secno.\the\subsecno}%
+}
+
+\outer\parseargdef\appendixsubsec{\apphead2{#1}} % normally calls appendixsubseczzz
+\def\appendixsubseczzz#1{%
+ \global\subsubsecno=0 \global\advance\subsecno by 1
+ \sectionheading{#1}{subsec}{Yappendix}%
+ {\appendixletter.\the\secno.\the\subsecno}%
+}
+
+\outer\parseargdef\unnumberedsubsec{\unnmhead2{#1}} %normally calls unnumberedsubseczzz
+\def\unnumberedsubseczzz#1{%
+ \global\subsubsecno=0 \global\advance\subsecno by 1
+ \sectionheading{#1}{subsec}{Ynothing}%
+ {\the\unnumberedno.\the\secno.\the\subsecno}%
+}
+
+% Subsubsections.
+\outer\parseargdef\numberedsubsubsec{\numhead3{#1}} % normally numberedsubsubseczzz
+\def\numberedsubsubseczzz#1{%
+ \global\advance\subsubsecno by 1
+ \sectionheading{#1}{subsubsec}{Ynumbered}%
+ {\the\chapno.\the\secno.\the\subsecno.\the\subsubsecno}%
+}
+
+\outer\parseargdef\appendixsubsubsec{\apphead3{#1}} % normally appendixsubsubseczzz
+\def\appendixsubsubseczzz#1{%
+ \global\advance\subsubsecno by 1
+ \sectionheading{#1}{subsubsec}{Yappendix}%
+ {\appendixletter.\the\secno.\the\subsecno.\the\subsubsecno}%
+}
+
+\outer\parseargdef\unnumberedsubsubsec{\unnmhead3{#1}} %normally unnumberedsubsubseczzz
+\def\unnumberedsubsubseczzz#1{%
+ \global\advance\subsubsecno by 1
+ \sectionheading{#1}{subsubsec}{Ynothing}%
+ {\the\unnumberedno.\the\secno.\the\subsecno.\the\subsubsecno}%
+}
+
+% These macros control what the section commands do, according
+% to what kind of chapter we are in (ordinary, appendix, or unnumbered).
+% Define them by default for a numbered chapter.
+\let\section = \numberedsec
+\let\subsection = \numberedsubsec
+\let\subsubsection = \numberedsubsubsec
+
+% Define @majorheading, @heading and @subheading
+
+% NOTE on use of \vbox for chapter headings, section headings, and such:
+% 1) We use \vbox rather than the earlier \line to permit
+% overlong headings to fold.
+% 2) \hyphenpenalty is set to 10000 because hyphenation in a
+% heading is obnoxious; this forbids it.
+% 3) Likewise, headings look best if no \parindent is used, and
+% if justification is not attempted. Hence \raggedright.
+
+
+\def\majorheading{%
+ {\advance\chapheadingskip by 10pt \chapbreak }%
+ \parsearg\chapheadingzzz
+}
+
+\def\chapheading{\chapbreak \parsearg\chapheadingzzz}
+\def\chapheadingzzz#1{%
+ {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
+ \parindent=0pt\raggedright
+ \rm #1\hfill}}%
+ \bigskip \par\penalty 200\relax
+ \suppressfirstparagraphindent
+}
+
+% @heading, @subheading, @subsubheading.
+\parseargdef\heading{\sectionheading{#1}{sec}{Yomitfromtoc}{}
+ \suppressfirstparagraphindent}
+\parseargdef\subheading{\sectionheading{#1}{subsec}{Yomitfromtoc}{}
+ \suppressfirstparagraphindent}
+\parseargdef\subsubheading{\sectionheading{#1}{subsubsec}{Yomitfromtoc}{}
+ \suppressfirstparagraphindent}
+
+% These macros generate a chapter, section, etc. heading only
+% (including whitespace, linebreaking, etc. around it),
+% given all the information in convenient, parsed form.
+
+%%% Args are the skip and penalty (usually negative)
+\def\dobreak#1#2{\par\ifdim\lastskip<#1\removelastskip\penalty#2\vskip#1\fi}
+
+%%% Define plain chapter starts, and page on/off switching for it
+% Parameter controlling skip before chapter headings (if needed)
+
+\newskip\chapheadingskip
+
+\def\chapbreak{\dobreak \chapheadingskip {-4000}}
+\def\chappager{\par\vfill\supereject}
+% Because \domark is called before \chapoddpage, the filler page will
+% get the headings for the next chapter, which is wrong. But we don't
+% care -- we just disable all headings on the filler page.
+\def\chapoddpage{%
+ \chappager
+ \ifodd\pageno \else
+ \begingroup
+ \evenheadline={\hfil}\evenfootline={\hfil}%
+ \oddheadline={\hfil}\oddfootline={\hfil}%
+ \hbox to 0pt{}%
+ \chappager
+ \endgroup
+ \fi
+}
+
+\def\setchapternewpage #1 {\csname CHAPPAG#1\endcsname}
+
+\def\CHAPPAGoff{%
+\global\let\contentsalignmacro = \chappager
+\global\let\pchapsepmacro=\chapbreak
+\global\let\pagealignmacro=\chappager}
+
+\def\CHAPPAGon{%
+\global\let\contentsalignmacro = \chappager
+\global\let\pchapsepmacro=\chappager
+\global\let\pagealignmacro=\chappager
+\global\def\HEADINGSon{\HEADINGSsingle}}
+
+\def\CHAPPAGodd{%
+\global\let\contentsalignmacro = \chapoddpage
+\global\let\pchapsepmacro=\chapoddpage
+\global\let\pagealignmacro=\chapoddpage
+\global\def\HEADINGSon{\HEADINGSdouble}}
+
+\CHAPPAGon
+
+% Chapter opening.
+%
+% #1 is the text, #2 is the section type (Ynumbered, Ynothing,
+% Yappendix, Yomitfromtoc), #3 the chapter number.
+%
+% To test against our argument.
+\def\Ynothingkeyword{Ynothing}
+\def\Yomitfromtockeyword{Yomitfromtoc}
+\def\Yappendixkeyword{Yappendix}
+%
+\def\chapmacro#1#2#3{%
+ % Insert the first mark before the heading break (see notes for \domark).
+ \let\prevchapterdefs=\lastchapterdefs
+ \let\prevsectiondefs=\lastsectiondefs
+ \gdef\lastsectiondefs{\gdef\thissectionname{}\gdef\thissectionnum{}%
+ \gdef\thissection{}}%
+ %
+ \def\temptype{#2}%
+ \ifx\temptype\Ynothingkeyword
+ \gdef\lastchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}%
+ \gdef\thischapter{\thischaptername}}%
+ \else\ifx\temptype\Yomitfromtockeyword
+ \gdef\lastchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}%
+ \gdef\thischapter{}}%
+ \else\ifx\temptype\Yappendixkeyword
+ \toks0={#1}%
+ \xdef\lastchapterdefs{%
+ \gdef\noexpand\thischaptername{\the\toks0}%
+ \gdef\noexpand\thischapternum{\appendixletter}%
+ \gdef\noexpand\thischapter{\putwordAppendix{} \noexpand\thischapternum:
+ \noexpand\thischaptername}%
+ }%
+ \else
+ \toks0={#1}%
+ \xdef\lastchapterdefs{%
+ \gdef\noexpand\thischaptername{\the\toks0}%
+ \gdef\noexpand\thischapternum{\the\chapno}%
+ \gdef\noexpand\thischapter{\putwordChapter{} \noexpand\thischapternum:
+ \noexpand\thischaptername}%
+ }%
+ \fi\fi\fi
+ %
+ % Output the mark. Pass it through \safewhatsit, to take care of
+ % the preceding space.
+ \safewhatsit\domark
+ %
+ % Insert the chapter heading break.
+ \pchapsepmacro
+ %
+ % Now the second mark, after the heading break. No break points
+ % between here and the heading.
+ \let\prevchapterdefs=\lastchapterdefs
+ \let\prevsectiondefs=\lastsectiondefs
+ \domark
+ %
+ {%
+ \chapfonts \rm
+ %
+ % Have to define \lastsection before calling \donoderef, because the
+ % xref code eventually uses it. On the other hand, it has to be called
+ % after \pchapsepmacro, or the headline will change too soon.
+ \gdef\lastsection{#1}%
+ %
+ % Only insert the separating space if we have a chapter/appendix
+ % number, and don't print the unnumbered ``number''.
+ \ifx\temptype\Ynothingkeyword
+ \setbox0 = \hbox{}%
+ \def\toctype{unnchap}%
+ \else\ifx\temptype\Yomitfromtockeyword
+ \setbox0 = \hbox{}% contents like unnumbered, but no toc entry
+ \def\toctype{omit}%
+ \else\ifx\temptype\Yappendixkeyword
+ \setbox0 = \hbox{\putwordAppendix{} #3\enspace}%
+ \def\toctype{app}%
+ \else
+ \setbox0 = \hbox{#3\enspace}%
+ \def\toctype{numchap}%
+ \fi\fi\fi
+ %
+ % Write the toc entry for this chapter. Must come before the
+ % \donoderef, because we include the current node name in the toc
+ % entry, and \donoderef resets it to empty.
+ \writetocentry{\toctype}{#1}{#3}%
+ %
+ % For pdftex, we have to write out the node definition (aka, make
+ % the pdfdest) after any page break, but before the actual text has
+ % been typeset. If the destination for the pdf outline is after the
+ % text, then jumping from the outline may wind up with the text not
+ % being visible, for instance under high magnification.
+ \donoderef{#2}%
+ %
+ % Typeset the actual heading.
+ \nobreak % Avoid page breaks at the interline glue.
+ \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \raggedright
+ \hangindent=\wd0 \centerparametersmaybe
+ \unhbox0 #1\par}%
+ }%
+ \nobreak\bigskip % no page break after a chapter title
+ \nobreak
+}
+
+% @centerchap -- centered and unnumbered.
+\let\centerparametersmaybe = \relax
+\def\centerparameters{%
+ \advance\rightskip by 3\rightskip
+ \leftskip = \rightskip
+ \parfillskip = 0pt
+}
+
+
+% I don't think this chapter style is supported any more, so I'm not
+% updating it with the new noderef stuff. We'll see. --karl, 11aug03.
+%
+\def\setchapterstyle #1 {\csname CHAPF#1\endcsname}
+%
+\def\unnchfopen #1{%
+\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
+ \parindent=0pt\raggedright
+ \rm #1\hfill}}\bigskip \par\nobreak
+}
+\def\chfopen #1#2{\chapoddpage {\chapfonts
+\vbox to 3in{\vfil \hbox to\hsize{\hfil #2} \hbox to\hsize{\hfil #1} \vfil}}%
+\par\penalty 5000 %
+}
+\def\centerchfopen #1{%
+\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
+ \parindent=0pt
+ \hfill {\rm #1}\hfill}}\bigskip \par\nobreak
+}
+\def\CHAPFopen{%
+ \global\let\chapmacro=\chfopen
+ \global\let\centerchapmacro=\centerchfopen}
+
+
+% Section titles. These macros combine the section number parts and
+% call the generic \sectionheading to do the printing.
+%
+\newskip\secheadingskip
+\def\secheadingbreak{\dobreak \secheadingskip{-1000}}
+
+% Subsection titles.
+\newskip\subsecheadingskip
+\def\subsecheadingbreak{\dobreak \subsecheadingskip{-500}}
+
+% Subsubsection titles.
+\def\subsubsecheadingskip{\subsecheadingskip}
+\def\subsubsecheadingbreak{\subsecheadingbreak}
+
+
+% Print any size, any type, section title.
+%
+% #1 is the text, #2 is the section level (sec/subsec/subsubsec), #3 is
+% the section type for xrefs (Ynumbered, Ynothing, Yappendix), #4 is the
+% section number.
+%
+\def\seckeyword{sec}
+%
+\def\sectionheading#1#2#3#4{%
+ {%
+ % Switch to the right set of fonts.
+ \csname #2fonts\endcsname \rm
+ %
+ \def\sectionlevel{#2}%
+ \def\temptype{#3}%
+ %
+ % Insert first mark before the heading break (see notes for \domark).
+ \let\prevsectiondefs=\lastsectiondefs
+ \ifx\temptype\Ynothingkeyword
+ \ifx\sectionlevel\seckeyword
+ \gdef\lastsectiondefs{\gdef\thissectionname{#1}\gdef\thissectionnum{}%
+ \gdef\thissection{\thissectionname}}%
+ \fi
+ \else\ifx\temptype\Yomitfromtockeyword
+ % Don't redefine \thissection.
+ \else\ifx\temptype\Yappendixkeyword
+ \ifx\sectionlevel\seckeyword
+ \toks0={#1}%
+ \xdef\lastsectiondefs{%
+ \gdef\noexpand\thissectionname{\the\toks0}%
+ \gdef\noexpand\thissectionnum{#4}%
+ \gdef\noexpand\thissection{\putwordSection{} \noexpand\thissectionnum:
+ \noexpand\thissectionname}%
+ }%
+ \fi
+ \else
+ \ifx\sectionlevel\seckeyword
+ \toks0={#1}%
+ \xdef\lastsectiondefs{%
+ \gdef\noexpand\thissectionname{\the\toks0}%
+ \gdef\noexpand\thissectionnum{#4}%
+ \gdef\noexpand\thissection{\putwordSection{} \noexpand\thissectionnum:
+ \noexpand\thissectionname}%
+ }%
+ \fi
+ \fi\fi\fi
+ %
+ % Output the mark. Pass it through \safewhatsit, to take care of
+ % the preceding space.
+ \safewhatsit\domark
+ %
+ % Insert space above the heading.
+ \csname #2headingbreak\endcsname
+ %
+ % Now the second mark, after the heading break. No break points
+ % between here and the heading.
+ \let\prevsectiondefs=\lastsectiondefs
+ \domark
+ %
+ % Only insert the space after the number if we have a section number.
+ \ifx\temptype\Ynothingkeyword
+ \setbox0 = \hbox{}%
+ \def\toctype{unn}%
+ \gdef\lastsection{#1}%
+ \else\ifx\temptype\Yomitfromtockeyword
+ % for @headings -- no section number, don't include in toc,
+ % and don't redefine \lastsection.
+ \setbox0 = \hbox{}%
+ \def\toctype{omit}%
+ \let\sectionlevel=\empty
+ \else\ifx\temptype\Yappendixkeyword
+ \setbox0 = \hbox{#4\enspace}%
+ \def\toctype{app}%
+ \gdef\lastsection{#1}%
+ \else
+ \setbox0 = \hbox{#4\enspace}%
+ \def\toctype{num}%
+ \gdef\lastsection{#1}%
+ \fi\fi\fi
+ %
+ % Write the toc entry (before \donoderef). See comments in \chapmacro.
+ \writetocentry{\toctype\sectionlevel}{#1}{#4}%
+ %
+ % Write the node reference (= pdf destination for pdftex).
+ % Again, see comments in \chapmacro.
+ \donoderef{#3}%
+ %
+ % Interline glue will be inserted when the vbox is completed.
+ % That glue will be a valid breakpoint for the page, since it'll be
+ % preceded by a whatsit (usually from the \donoderef, or from the
+ % \writetocentry if there was no node). We don't want to allow that
+ % break, since then the whatsits could end up on page n while the
+ % section is on page n+1, thus toc/etc. are wrong. Debian bug 276000.
+ \nobreak
+ %
+ % Output the actual section heading.
+ \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \raggedright
+ \hangindent=\wd0 % zero if no section number
+ \unhbox0 #1}%
+ }%
+ % Add extra space after the heading -- half of whatever came above it.
+ % Don't allow stretch, though.
+ \kern .5 \csname #2headingskip\endcsname
+ %
+ % Do not let the kern be a potential breakpoint, as it would be if it
+ % was followed by glue.
+ \nobreak
+ %
+ % We'll almost certainly start a paragraph next, so don't let that
+ % glue accumulate. (Not a breakpoint because it's preceded by a
+ % discardable item.)
+ \vskip-\parskip
+ %
+ % This is purely so the last item on the list is a known \penalty >
+ % 10000. This is so \startdefun can avoid allowing breakpoints after
+ % section headings. Otherwise, it would insert a valid breakpoint between:
+ %
+ % @section sec-whatever
+ % @deffn def-whatever
+ \penalty 10001
+}
+
+
+\message{toc,}
+% Table of contents.
+\newwrite\tocfile
+
+% Write an entry to the toc file, opening it if necessary.
+% Called from @chapter, etc.
+%
+% Example usage: \writetocentry{sec}{Section Name}{\the\chapno.\the\secno}
+% We append the current node name (if any) and page number as additional
+% arguments for the \{chap,sec,...}entry macros which will eventually
+% read this. The node name is used in the pdf outlines as the
+% destination to jump to.
+%
+% We open the .toc file for writing here instead of at @setfilename (or
+% any other fixed time) so that @contents can be anywhere in the document.
+% But if #1 is `omit', then we don't do anything. This is used for the
+% table of contents chapter openings themselves.
+%
+\newif\iftocfileopened
+\def\omitkeyword{omit}%
+%
+\def\writetocentry#1#2#3{%
+ \edef\writetoctype{#1}%
+ \ifx\writetoctype\omitkeyword \else
+ \iftocfileopened\else
+ \immediate\openout\tocfile = \jobname.toc
+ \global\tocfileopenedtrue
+ \fi
+ %
+ \iflinks
+ {\atdummies
+ \edef\temp{%
+ \write\tocfile{@#1entry{#2}{#3}{\lastnode}{\noexpand\folio}}}%
+ \temp
+ }%
+ \fi
+ \fi
+ %
+ % Tell \shipout to create a pdf destination on each page, if we're
+ % writing pdf. These are used in the table of contents. We can't
+ % just write one on every page because the title pages are numbered
+ % 1 and 2 (the page numbers aren't printed), and so are the first
+ % two pages of the document. Thus, we'd have two destinations named
+ % `1', and two named `2'.
+ \ifpdf \global\pdfmakepagedesttrue \fi
+}
+
+
+% These characters do not print properly in the Computer Modern roman
+% fonts, so we must take special care. This is more or less redundant
+% with the Texinfo input format setup at the end of this file.
+%
+\def\activecatcodes{%
+ \catcode`\"=\active
+ \catcode`\$=\active
+ \catcode`\<=\active
+ \catcode`\>=\active
+ \catcode`\\=\active
+ \catcode`\^=\active
+ \catcode`\_=\active
+ \catcode`\|=\active
+ \catcode`\~=\active
+}
+
+
+% Read the toc file, which is essentially Texinfo input.
+\def\readtocfile{%
+ \setupdatafile
+ \activecatcodes
+ \input \tocreadfilename
+}
+
+\newskip\contentsrightmargin \contentsrightmargin=1in
+\newcount\savepageno
+\newcount\lastnegativepageno \lastnegativepageno = -1
+
+% Prepare to read what we've written to \tocfile.
+%
+\def\startcontents#1{%
+ % If @setchapternewpage on, and @headings double, the contents should
+ % start on an odd page, unlike chapters. Thus, we maintain
+ % \contentsalignmacro in parallel with \pagealignmacro.
+ % From: Torbjorn Granlund <tege@matematik.su.se>
+ \contentsalignmacro
+ \immediate\closeout\tocfile
+ %
+ % Don't need to put `Contents' or `Short Contents' in the headline.
+ % It is abundantly clear what they are.
+ \chapmacro{#1}{Yomitfromtoc}{}%
+ %
+ \savepageno = \pageno
+ \begingroup % Set up to handle contents files properly.
+ \raggedbottom % Worry more about breakpoints than the bottom.
+ \advance\hsize by -\contentsrightmargin % Don't use the full line length.
+ %
+ % Roman numerals for page numbers.
+ \ifnum \pageno>0 \global\pageno = \lastnegativepageno \fi
+}
+
+% redefined for the two-volume lispref. We always output on
+% \jobname.toc even if this is redefined.
+%
+\def\tocreadfilename{\jobname.toc}
+
+% Normal (long) toc.
+%
+\def\contents{%
+ \startcontents{\putwordTOC}%
+ \openin 1 \tocreadfilename\space
+ \ifeof 1 \else
+ \readtocfile
+ \fi
+ \vfill \eject
+ \contentsalignmacro % in case @setchapternewpage odd is in effect
+ \ifeof 1 \else
+ \pdfmakeoutlines
+ \fi
+ \closein 1
+ \endgroup
+ \lastnegativepageno = \pageno
+ \global\pageno = \savepageno
+}
+
+% And just the chapters.
+\def\summarycontents{%
+ \startcontents{\putwordShortTOC}%
+ %
+ \let\numchapentry = \shortchapentry
+ \let\appentry = \shortchapentry
+ \let\unnchapentry = \shortunnchapentry
+ % We want a true roman here for the page numbers.
+ \secfonts
+ \let\rm=\shortcontrm \let\bf=\shortcontbf
+ \let\sl=\shortcontsl \let\tt=\shortconttt
+ \rm
+ \hyphenpenalty = 10000
+ \advance\baselineskip by 1pt % Open it up a little.
+ \def\numsecentry##1##2##3##4{}
+ \let\appsecentry = \numsecentry
+ \let\unnsecentry = \numsecentry
+ \let\numsubsecentry = \numsecentry
+ \let\appsubsecentry = \numsecentry
+ \let\unnsubsecentry = \numsecentry
+ \let\numsubsubsecentry = \numsecentry
+ \let\appsubsubsecentry = \numsecentry
+ \let\unnsubsubsecentry = \numsecentry
+ \openin 1 \tocreadfilename\space
+ \ifeof 1 \else
+ \readtocfile
+ \fi
+ \closein 1
+ \vfill \eject
+ \contentsalignmacro % in case @setchapternewpage odd is in effect
+ \endgroup
+ \lastnegativepageno = \pageno
+ \global\pageno = \savepageno
+}
+\let\shortcontents = \summarycontents
+
+% Typeset the label for a chapter or appendix for the short contents.
+% The arg is, e.g., `A' for an appendix, or `3' for a chapter.
+%
+\def\shortchaplabel#1{%
+ % This space should be enough, since a single number is .5em, and the
+ % widest letter (M) is 1em, at least in the Computer Modern fonts.
+ % But use \hss just in case.
+ % (This space doesn't include the extra space that gets added after
+ % the label; that gets put in by \shortchapentry above.)
+ %
+ % We'd like to right-justify chapter numbers, but that looks strange
+ % with appendix letters. And right-justifying numbers and
+ % left-justifying letters looks strange when there is less than 10
+ % chapters. Have to read the whole toc once to know how many chapters
+ % there are before deciding ...
+ \hbox to 1em{#1\hss}%
+}
+
+% These macros generate individual entries in the table of contents.
+% The first argument is the chapter or section name.
+% The last argument is the page number.
+% The arguments in between are the chapter number, section number, ...
+
+% Chapters, in the main contents.
+\def\numchapentry#1#2#3#4{\dochapentry{#2\labelspace#1}{#4}}
+%
+% Chapters, in the short toc.
+% See comments in \dochapentry re vbox and related settings.
+\def\shortchapentry#1#2#3#4{%
+ \tocentry{\shortchaplabel{#2}\labelspace #1}{\doshortpageno\bgroup#4\egroup}%
+}
+
+% Appendices, in the main contents.
+% Need the word Appendix, and a fixed-size box.
+%
+\def\appendixbox#1{%
+ % We use M since it's probably the widest letter.
+ \setbox0 = \hbox{\putwordAppendix{} M}%
+ \hbox to \wd0{\putwordAppendix{} #1\hss}}
+%
+\def\appentry#1#2#3#4{\dochapentry{\appendixbox{#2}\labelspace#1}{#4}}
+
+% Unnumbered chapters.
+\def\unnchapentry#1#2#3#4{\dochapentry{#1}{#4}}
+\def\shortunnchapentry#1#2#3#4{\tocentry{#1}{\doshortpageno\bgroup#4\egroup}}
+
+% Sections.
+\def\numsecentry#1#2#3#4{\dosecentry{#2\labelspace#1}{#4}}
+\let\appsecentry=\numsecentry
+\def\unnsecentry#1#2#3#4{\dosecentry{#1}{#4}}
+
+% Subsections.
+\def\numsubsecentry#1#2#3#4{\dosubsecentry{#2\labelspace#1}{#4}}
+\let\appsubsecentry=\numsubsecentry
+\def\unnsubsecentry#1#2#3#4{\dosubsecentry{#1}{#4}}
+
+% And subsubsections.
+\def\numsubsubsecentry#1#2#3#4{\dosubsubsecentry{#2\labelspace#1}{#4}}
+\let\appsubsubsecentry=\numsubsubsecentry
+\def\unnsubsubsecentry#1#2#3#4{\dosubsubsecentry{#1}{#4}}
+
+% This parameter controls the indentation of the various levels.
+% Same as \defaultparindent.
+\newdimen\tocindent \tocindent = 15pt
+
+% Now for the actual typesetting. In all these, #1 is the text and #2 is the
+% page number.
+%
+% If the toc has to be broken over pages, we want it to be at chapters
+% if at all possible; hence the \penalty.
+\def\dochapentry#1#2{%
+ \penalty-300 \vskip1\baselineskip plus.33\baselineskip minus.25\baselineskip
+ \begingroup
+ \chapentryfonts
+ \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+ \endgroup
+ \nobreak\vskip .25\baselineskip plus.1\baselineskip
+}
+
+\def\dosecentry#1#2{\begingroup
+ \secentryfonts \leftskip=\tocindent
+ \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+\endgroup}
+
+\def\dosubsecentry#1#2{\begingroup
+ \subsecentryfonts \leftskip=2\tocindent
+ \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+\endgroup}
+
+\def\dosubsubsecentry#1#2{\begingroup
+ \subsubsecentryfonts \leftskip=3\tocindent
+ \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+\endgroup}
+
+% We use the same \entry macro as for the index entries.
+\let\tocentry = \entry
+
+% Space between chapter (or whatever) number and the title.
+\def\labelspace{\hskip1em \relax}
+
+\def\dopageno#1{{\rm #1}}
+\def\doshortpageno#1{{\rm #1}}
+
+\def\chapentryfonts{\secfonts \rm}
+\def\secentryfonts{\textfonts}
+\def\subsecentryfonts{\textfonts}
+\def\subsubsecentryfonts{\textfonts}
+
+
+\message{environments,}
+% @foo ... @end foo.
+
+% @point{}, @result{}, @expansion{}, @print{}, @equiv{}.
+%
+% Since these characters are used in examples, it should be an even number of
+% \tt widths. Each \tt character is 1en, so two makes it 1em.
+%
+\def\point{$\star$}
+\def\result{\leavevmode\raise.15ex\hbox to 1em{\hfil$\Rightarrow$\hfil}}
+\def\expansion{\leavevmode\raise.1ex\hbox to 1em{\hfil$\mapsto$\hfil}}
+\def\print{\leavevmode\lower.1ex\hbox to 1em{\hfil$\dashv$\hfil}}
+\def\equiv{\leavevmode\lower.1ex\hbox to 1em{\hfil$\ptexequiv$\hfil}}
+
+% The @error{} command.
+% Adapted from the TeXbook's \boxit.
+%
+\newbox\errorbox
+%
+{\tentt \global\dimen0 = 3em}% Width of the box.
+\dimen2 = .55pt % Thickness of rules
+% The text. (`r' is open on the right, `e' somewhat less so on the left.)
+\setbox0 = \hbox{\kern-.75pt \reducedsf error\kern-1.5pt}
+%
+\setbox\errorbox=\hbox to \dimen0{\hfil
+ \hsize = \dimen0 \advance\hsize by -5.8pt % Space to left+right.
+ \advance\hsize by -2\dimen2 % Rules.
+ \vbox{%
+ \hrule height\dimen2
+ \hbox{\vrule width\dimen2 \kern3pt % Space to left of text.
+ \vtop{\kern2.4pt \box0 \kern2.4pt}% Space above/below.
+ \kern3pt\vrule width\dimen2}% Space to right.
+ \hrule height\dimen2}
+ \hfil}
+%
+\def\error{\leavevmode\lower.7ex\copy\errorbox}
+
+% @tex ... @end tex escapes into raw Tex temporarily.
+% One exception: @ is still an escape character, so that @end tex works.
+% But \@ or @@ will get a plain tex @ character.
+
+\envdef\tex{%
+ \catcode `\\=0 \catcode `\{=1 \catcode `\}=2
+ \catcode `\$=3 \catcode `\&=4 \catcode `\#=6
+ \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie
+ \catcode `\%=14
+ \catcode `\+=\other
+ \catcode `\"=\other
+ \catcode `\|=\other
+ \catcode `\<=\other
+ \catcode `\>=\other
+ \escapechar=`\\
+ %
+ \let\b=\ptexb
+ \let\bullet=\ptexbullet
+ \let\c=\ptexc
+ \let\,=\ptexcomma
+ \let\.=\ptexdot
+ \let\dots=\ptexdots
+ \let\equiv=\ptexequiv
+ \let\!=\ptexexclam
+ \let\i=\ptexi
+ \let\indent=\ptexindent
+ \let\noindent=\ptexnoindent
+ \let\{=\ptexlbrace
+ \let\+=\tabalign
+ \let\}=\ptexrbrace
+ \let\/=\ptexslash
+ \let\*=\ptexstar
+ \let\t=\ptext
+ \let\frenchspacing=\plainfrenchspacing
+ %
+ \def\endldots{\mathinner{\ldots\ldots\ldots\ldots}}%
+ \def\enddots{\relax\ifmmode\endldots\else$\mathsurround=0pt \endldots\,$\fi}%
+ \def\@{@}%
+}
+% There is no need to define \Etex.
+
+% Define @lisp ... @end lisp.
+% @lisp environment forms a group so it can rebind things,
+% including the definition of @end lisp (which normally is erroneous).
+
+% Amount to narrow the margins by for @lisp.
+\newskip\lispnarrowing \lispnarrowing=0.4in
+
+% This is the definition that ^^M gets inside @lisp, @example, and other
+% such environments. \null is better than a space, since it doesn't
+% have any width.
+\def\lisppar{\null\endgraf}
+
+% This space is always present above and below environments.
+\newskip\envskipamount \envskipamount = 0pt
+
+% Make spacing and below environment symmetrical. We use \parskip here
+% to help in doing that, since in @example-like environments \parskip
+% is reset to zero; thus the \afterenvbreak inserts no space -- but the
+% start of the next paragraph will insert \parskip.
+%
+\def\aboveenvbreak{{%
+ % =10000 instead of <10000 because of a special case in \itemzzz and
+ % \sectionheading, q.v.
+ \ifnum \lastpenalty=10000 \else
+ \advance\envskipamount by \parskip
+ \endgraf
+ \ifdim\lastskip<\envskipamount
+ \removelastskip
+ % it's not a good place to break if the last penalty was \nobreak
+ % or better ...
+ \ifnum\lastpenalty<10000 \penalty-50 \fi
+ \vskip\envskipamount
+ \fi
+ \fi
+}}
+
+\let\afterenvbreak = \aboveenvbreak
+
+% \nonarrowing is a flag. If "set", @lisp etc don't narrow margins; it will
+% also clear it, so that its embedded environments do the narrowing again.
+\let\nonarrowing=\relax
+
+% @cartouche ... @end cartouche: draw rectangle w/rounded corners around
+% environment contents.
+\font\circle=lcircle10
+\newdimen\circthick
+\newdimen\cartouter\newdimen\cartinner
+\newskip\normbskip\newskip\normpskip\newskip\normlskip
+\circthick=\fontdimen8\circle
+%
+\def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth
+\def\ctr{{\hskip 6pt\circle\char'010}}
+\def\cbl{{\circle\char'012\hskip -6pt}}
+\def\cbr{{\hskip 6pt\circle\char'011}}
+\def\carttop{\hbox to \cartouter{\hskip\lskip
+ \ctl\leaders\hrule height\circthick\hfil\ctr
+ \hskip\rskip}}
+\def\cartbot{\hbox to \cartouter{\hskip\lskip
+ \cbl\leaders\hrule height\circthick\hfil\cbr
+ \hskip\rskip}}
+%
+\newskip\lskip\newskip\rskip
+
+\envdef\cartouche{%
+ \ifhmode\par\fi % can't be in the midst of a paragraph.
+ \startsavinginserts
+ \lskip=\leftskip \rskip=\rightskip
+ \leftskip=0pt\rightskip=0pt % we want these *outside*.
+ \cartinner=\hsize \advance\cartinner by-\lskip
+ \advance\cartinner by-\rskip
+ \cartouter=\hsize
+ \advance\cartouter by 18.4pt % allow for 3pt kerns on either
+ % side, and for 6pt waste from
+ % each corner char, and rule thickness
+ \normbskip=\baselineskip \normpskip=\parskip \normlskip=\lineskip
+ % Flag to tell @lisp, etc., not to narrow margin.
+ \let\nonarrowing = t%
+ \vbox\bgroup
+ \baselineskip=0pt\parskip=0pt\lineskip=0pt
+ \carttop
+ \hbox\bgroup
+ \hskip\lskip
+ \vrule\kern3pt
+ \vbox\bgroup
+ \kern3pt
+ \hsize=\cartinner
+ \baselineskip=\normbskip
+ \lineskip=\normlskip
+ \parskip=\normpskip
+ \vskip -\parskip
+ \comment % For explanation, see the end of \def\group.
+}
+\def\Ecartouche{%
+ \ifhmode\par\fi
+ \kern3pt
+ \egroup
+ \kern3pt\vrule
+ \hskip\rskip
+ \egroup
+ \cartbot
+ \egroup
+ \checkinserts
+}
+
+
+% This macro is called at the beginning of all the @example variants,
+% inside a group.
+\def\nonfillstart{%
+ \aboveenvbreak
+ \hfuzz = 12pt % Don't be fussy
+ \sepspaces % Make spaces be word-separators rather than space tokens.
+ \let\par = \lisppar % don't ignore blank lines
+ \obeylines % each line of input is a line of output
+ \parskip = 0pt
+ \parindent = 0pt
+ \emergencystretch = 0pt % don't try to avoid overfull boxes
+ \ifx\nonarrowing\relax
+ \advance \leftskip by \lispnarrowing
+ \exdentamount=\lispnarrowing
+ \else
+ \let\nonarrowing = \relax
+ \fi
+ \let\exdent=\nofillexdent
+}
+
+% If you want all examples etc. small: @set dispenvsize small.
+% If you want even small examples the full size: @set dispenvsize nosmall.
+% This affects the following displayed environments:
+% @example, @display, @format, @lisp
+%
+\def\smallword{small}
+\def\nosmallword{nosmall}
+\let\SETdispenvsize\relax
+\def\setnormaldispenv{%
+ \ifx\SETdispenvsize\smallword
+ % end paragraph for sake of leading, in case document has no blank
+ % line. This is redundant with what happens in \aboveenvbreak, but
+ % we need to do it before changing the fonts, and it's inconvenient
+ % to change the fonts afterward.
+ \ifnum \lastpenalty=10000 \else \endgraf \fi
+ \smallexamplefonts \rm
+ \fi
+}
+\def\setsmalldispenv{%
+ \ifx\SETdispenvsize\nosmallword
+ \else
+ \ifnum \lastpenalty=10000 \else \endgraf \fi
+ \smallexamplefonts \rm
+ \fi
+}
+
+% We often define two environments, @foo and @smallfoo.
+% Let's do it by one command:
+\def\makedispenv #1#2{
+ \expandafter\envdef\csname#1\endcsname {\setnormaldispenv #2}
+ \expandafter\envdef\csname small#1\endcsname {\setsmalldispenv #2}
+ \expandafter\let\csname E#1\endcsname \afterenvbreak
+ \expandafter\let\csname Esmall#1\endcsname \afterenvbreak
+}
+
+% Define two synonyms:
+\def\maketwodispenvs #1#2#3{
+ \makedispenv{#1}{#3}
+ \makedispenv{#2}{#3}
+}
+
+% @lisp: indented, narrowed, typewriter font; @example: same as @lisp.
+%
+% @smallexample and @smalllisp: use smaller fonts.
+% Originally contributed by Pavel@xerox.
+%
+\maketwodispenvs {lisp}{example}{%
+ \nonfillstart
+ \tt\quoteexpand
+ \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special.
+ \gobble % eat return
+}
+% @display/@smalldisplay: same as @lisp except keep current font.
+%
+\makedispenv {display}{%
+ \nonfillstart
+ \gobble
+}
+
+% @format/@smallformat: same as @display except don't narrow margins.
+%
+\makedispenv{format}{%
+ \let\nonarrowing = t%
+ \nonfillstart
+ \gobble
+}
+
+% @flushleft: same as @format, but doesn't obey \SETdispenvsize.
+\envdef\flushleft{%
+ \let\nonarrowing = t%
+ \nonfillstart
+ \gobble
+}
+\let\Eflushleft = \afterenvbreak
+
+% @flushright.
+%
+\envdef\flushright{%
+ \let\nonarrowing = t%
+ \nonfillstart
+ \advance\leftskip by 0pt plus 1fill
+ \gobble
+}
+\let\Eflushright = \afterenvbreak
+
+
+% @quotation does normal linebreaking (hence we can't use \nonfillstart)
+% and narrows the margins. We keep \parskip nonzero in general, since
+% we're doing normal filling. So, when using \aboveenvbreak and
+% \afterenvbreak, temporarily make \parskip 0.
+%
+\envdef\quotation{%
+ {\parskip=0pt \aboveenvbreak}% because \aboveenvbreak inserts \parskip
+ \parindent=0pt
+ %
+ % @cartouche defines \nonarrowing to inhibit narrowing at next level down.
+ \ifx\nonarrowing\relax
+ \advance\leftskip by \lispnarrowing
+ \advance\rightskip by \lispnarrowing
+ \exdentamount = \lispnarrowing
+ \else
+ \let\nonarrowing = \relax
+ \fi
+ \parsearg\quotationlabel
+}
+
+% We have retained a nonzero parskip for the environment, since we're
+% doing normal filling.
+%
+\def\Equotation{%
+ \par
+ \ifx\quotationauthor\undefined\else
+ % indent a bit.
+ \leftline{\kern 2\leftskip \sl ---\quotationauthor}%
+ \fi
+ {\parskip=0pt \afterenvbreak}%
+}
+
+% If we're given an argument, typeset it in bold with a colon after.
+\def\quotationlabel#1{%
+ \def\temp{#1}%
+ \ifx\temp\empty \else
+ {\bf #1: }%
+ \fi
+}
+
+
+% LaTeX-like @verbatim...@end verbatim and @verb{<char>...<char>}
+% If we want to allow any <char> as delimiter,
+% we need the curly braces so that makeinfo sees the @verb command, eg:
+% `@verbx...x' would look like the '@verbx' command. --janneke@gnu.org
+%
+% [Knuth]: Donald Ervin Knuth, 1996. The TeXbook.
+%
+% [Knuth] p.344; only we need to do the other characters Texinfo sets
+% active too. Otherwise, they get lost as the first character on a
+% verbatim line.
+\def\dospecials{%
+ \do\ \do\\\do\{\do\}\do\$\do\&%
+ \do\#\do\^\do\^^K\do\_\do\^^A\do\%\do\~%
+ \do\<\do\>\do\|\do\@\do+\do\"%
+}
+%
+% [Knuth] p. 380
+\def\uncatcodespecials{%
+ \def\do##1{\catcode`##1=\other}\dospecials}
+%
+% [Knuth] pp. 380,381,391
+% Disable Spanish ligatures ?` and !` of \tt font
+\begingroup
+ \catcode`\`=\active\gdef`{\relax\lq}
+\endgroup
+%
+% Setup for the @verb command.
+%
+% Eight spaces for a tab
+\begingroup
+ \catcode`\^^I=\active
+ \gdef\tabeightspaces{\catcode`\^^I=\active\def^^I{\ \ \ \ \ \ \ \ }}
+\endgroup
+%
+\def\setupverb{%
+ \tt % easiest (and conventionally used) font for verbatim
+ \def\par{\leavevmode\endgraf}%
+ \catcode`\`=\active
+ \tabeightspaces
+ % Respect line breaks,
+ % print special symbols as themselves, and
+ % make each space count
+ % must do in this order:
+ \obeylines \uncatcodespecials \sepspaces
+}
+
+% Setup for the @verbatim environment
+%
+% Real tab expansion
+\newdimen\tabw \setbox0=\hbox{\tt\space} \tabw=8\wd0 % tab amount
+%
+\def\starttabbox{\setbox0=\hbox\bgroup}
+
+% Allow an option to not replace quotes with a regular directed right
+% quote/apostrophe (char 0x27), but instead use the undirected quote
+% from cmtt (char 0x0d). The undirected quote is ugly, so don't make it
+% the default, but it works for pasting with more pdf viewers (at least
+% evince), the lilypond developers report. xpdf does work with the
+% regular 0x27.
+%
+\def\codequoteright{%
+ \expandafter\ifx\csname SETtxicodequoteundirected\endcsname\relax
+ \expandafter\ifx\csname SETcodequoteundirected\endcsname\relax
+ '%
+ \else \char'15 \fi
+ \else \char'15 \fi
+}
+%
+% and a similar option for the left quote char vs. a grave accent.
+% Modern fonts display ASCII 0x60 as a grave accent, so some people like
+% the code environments to do likewise.
+%
+\def\codequoteleft{%
+ \expandafter\ifx\csname SETtxicodequotebacktick\endcsname\relax
+ \expandafter\ifx\csname SETcodequotebacktick\endcsname\relax
+ `%
+ \else \char'22 \fi
+ \else \char'22 \fi
+}
+%
+\begingroup
+ \catcode`\^^I=\active
+ \gdef\tabexpand{%
+ \catcode`\^^I=\active
+ \def^^I{\leavevmode\egroup
+ \dimen0=\wd0 % the width so far, or since the previous tab
+ \divide\dimen0 by\tabw
+ \multiply\dimen0 by\tabw % compute previous multiple of \tabw
+ \advance\dimen0 by\tabw % advance to next multiple of \tabw
+ \wd0=\dimen0 \box0 \starttabbox
+ }%
+ }
+ \catcode`\'=\active
+ \gdef\rquoteexpand{\catcode\rquoteChar=\active \def'{\codequoteright}}%
+ %
+ \catcode`\`=\active
+ \gdef\lquoteexpand{\catcode\lquoteChar=\active \def`{\codequoteleft}}%
+ %
+ \gdef\quoteexpand{\rquoteexpand \lquoteexpand}%
+\endgroup
+
+% start the verbatim environment.
+\def\setupverbatim{%
+ \let\nonarrowing = t%
+ \nonfillstart
+ % Easiest (and conventionally used) font for verbatim
+ \tt
+ \def\par{\leavevmode\egroup\box0\endgraf}%
+ \catcode`\`=\active
+ \tabexpand
+ \quoteexpand
+ % Respect line breaks,
+ % print special symbols as themselves, and
+ % make each space count
+ % must do in this order:
+ \obeylines \uncatcodespecials \sepspaces
+ \everypar{\starttabbox}%
+}
+
+% Do the @verb magic: verbatim text is quoted by unique
+% delimiter characters. Before first delimiter expect a
+% right brace, after last delimiter expect closing brace:
+%
+% \def\doverb'{'<char>#1<char>'}'{#1}
+%
+% [Knuth] p. 382; only eat outer {}
+\begingroup
+ \catcode`[=1\catcode`]=2\catcode`\{=\other\catcode`\}=\other
+ \gdef\doverb{#1[\def\next##1#1}[##1\endgroup]\next]
+\endgroup
+%
+\def\verb{\begingroup\setupverb\doverb}
+%
+%
+% Do the @verbatim magic: define the macro \doverbatim so that
+% the (first) argument ends when '@end verbatim' is reached, ie:
+%
+% \def\doverbatim#1@end verbatim{#1}
+%
+% For Texinfo it's a lot easier than for LaTeX,
+% because texinfo's \verbatim doesn't stop at '\end{verbatim}':
+% we need not redefine '\', '{' and '}'.
+%
+% Inspired by LaTeX's verbatim command set [latex.ltx]
+%
+\begingroup
+ \catcode`\ =\active
+ \obeylines %
+ % ignore everything up to the first ^^M, that's the newline at the end
+ % of the @verbatim input line itself. Otherwise we get an extra blank
+ % line in the output.
+ \xdef\doverbatim#1^^M#2@end verbatim{#2\noexpand\end\gobble verbatim}%
+ % We really want {...\end verbatim} in the body of the macro, but
+ % without the active space; thus we have to use \xdef and \gobble.
+\endgroup
+%
+\envdef\verbatim{%
+ \setupverbatim\doverbatim
+}
+\let\Everbatim = \afterenvbreak
+
+
+% @verbatiminclude FILE - insert text of file in verbatim environment.
+%
+\def\verbatiminclude{\parseargusing\filenamecatcodes\doverbatiminclude}
+%
+\def\doverbatiminclude#1{%
+ {%
+ \makevalueexpandable
+ \setupverbatim
+ \input #1
+ \afterenvbreak
+ }%
+}
+
+% @copying ... @end copying.
+% Save the text away for @insertcopying later.
+%
+% We save the uninterpreted tokens, rather than creating a box.
+% Saving the text in a box would be much easier, but then all the
+% typesetting commands (@smallbook, font changes, etc.) have to be done
+% beforehand -- and a) we want @copying to be done first in the source
+% file; b) letting users define the frontmatter in as flexible order as
+% possible is very desirable.
+%
+\def\copying{\checkenv{}\begingroup\scanargctxt\docopying}
+\def\docopying#1@end copying{\endgroup\def\copyingtext{#1}}
+%
+\def\insertcopying{%
+ \begingroup
+ \parindent = 0pt % paragraph indentation looks wrong on title page
+ \scanexp\copyingtext
+ \endgroup
+}
+
+
+\message{defuns,}
+% @defun etc.
+
+\newskip\defbodyindent \defbodyindent=.4in
+\newskip\defargsindent \defargsindent=50pt
+\newskip\deflastargmargin \deflastargmargin=18pt
+\newcount\defunpenalty
+
+% Start the processing of @deffn:
+\def\startdefun{%
+ \ifnum\lastpenalty<10000
+ \medbreak
+ \defunpenalty=10003 % Will keep this @deffn together with the
+ % following @def command, see below.
+ \else
+ % If there are two @def commands in a row, we'll have a \nobreak,
+ % which is there to keep the function description together with its
+ % header. But if there's nothing but headers, we need to allow a
+ % break somewhere. Check specifically for penalty 10002, inserted
+ % by \printdefunline, instead of 10000, since the sectioning
+ % commands also insert a nobreak penalty, and we don't want to allow
+ % a break between a section heading and a defun.
+ %
+ % As a minor refinement, we avoid "club" headers by signalling
+ % with penalty of 10003 after the very first @deffn in the
+ % sequence (see above), and penalty of 10002 after any following
+ % @def command.
+ \ifnum\lastpenalty=10002 \penalty2000 \else \defunpenalty=10002 \fi
+ %
+ % Similarly, after a section heading, do not allow a break.
+ % But do insert the glue.
+ \medskip % preceded by discardable penalty, so not a breakpoint
+ \fi
+ %
+ \parindent=0in
+ \advance\leftskip by \defbodyindent
+ \exdentamount=\defbodyindent
+}
+
+\def\dodefunx#1{%
+ % First, check whether we are in the right environment:
+ \checkenv#1%
+ %
+ % As above, allow line break if we have multiple x headers in a row.
+ % It's not a great place, though.
+ \ifnum\lastpenalty=10002 \penalty3000 \else \defunpenalty=10002 \fi
+ %
+ % And now, it's time to reuse the body of the original defun:
+ \expandafter\gobbledefun#1%
+}
+\def\gobbledefun#1\startdefun{}
+
+% \printdefunline \deffnheader{text}
+%
+\def\printdefunline#1#2{%
+ \begingroup
+ % call \deffnheader:
+ #1#2 \endheader
+ % common ending:
+ \interlinepenalty = 10000
+ \advance\rightskip by 0pt plus 1fil
+ \endgraf
+ \nobreak\vskip -\parskip
+ \penalty\defunpenalty % signal to \startdefun and \dodefunx
+ % Some of the @defun-type tags do not enable magic parentheses,
+ % rendering the following check redundant. But we don't optimize.
+ \checkparencounts
+ \endgroup
+}
+
+\def\Edefun{\endgraf\medbreak}
+
+% \makedefun{deffn} creates \deffn, \deffnx and \Edeffn;
+% the only thing remainnig is to define \deffnheader.
+%
+\def\makedefun#1{%
+ \expandafter\let\csname E#1\endcsname = \Edefun
+ \edef\temp{\noexpand\domakedefun
+ \makecsname{#1}\makecsname{#1x}\makecsname{#1header}}%
+ \temp
+}
+
+% \domakedefun \deffn \deffnx \deffnheader
+%
+% Define \deffn and \deffnx, without parameters.
+% \deffnheader has to be defined explicitly.
+%
+\def\domakedefun#1#2#3{%
+ \envdef#1{%
+ \startdefun
+ \parseargusing\activeparens{\printdefunline#3}%
+ }%
+ \def#2{\dodefunx#1}%
+ \def#3%
+}
+
+%%% Untyped functions:
+
+% @deffn category name args
+\makedefun{deffn}{\deffngeneral{}}
+
+% @deffn category class name args
+\makedefun{defop}#1 {\defopon{#1\ \putwordon}}
+
+% \defopon {category on}class name args
+\def\defopon#1#2 {\deffngeneral{\putwordon\ \code{#2}}{#1\ \code{#2}} }
+
+% \deffngeneral {subind}category name args
+%
+\def\deffngeneral#1#2 #3 #4\endheader{%
+ % Remember that \dosubind{fn}{foo}{} is equivalent to \doind{fn}{foo}.
+ \dosubind{fn}{\code{#3}}{#1}%
+ \defname{#2}{}{#3}\magicamp\defunargs{#4\unskip}%
+}
+
+%%% Typed functions:
+
+% @deftypefn category type name args
+\makedefun{deftypefn}{\deftypefngeneral{}}
+
+% @deftypeop category class type name args
+\makedefun{deftypeop}#1 {\deftypeopon{#1\ \putwordon}}
+
+% \deftypeopon {category on}class type name args
+\def\deftypeopon#1#2 {\deftypefngeneral{\putwordon\ \code{#2}}{#1\ \code{#2}} }
+
+% \deftypefngeneral {subind}category type name args
+%
+\def\deftypefngeneral#1#2 #3 #4 #5\endheader{%
+ \dosubind{fn}{\code{#4}}{#1}%
+ \defname{#2}{#3}{#4}\defunargs{#5\unskip}%
+}
+
+%%% Typed variables:
+
+% @deftypevr category type var args
+\makedefun{deftypevr}{\deftypecvgeneral{}}
+
+% @deftypecv category class type var args
+\makedefun{deftypecv}#1 {\deftypecvof{#1\ \putwordof}}
+
+% \deftypecvof {category of}class type var args
+\def\deftypecvof#1#2 {\deftypecvgeneral{\putwordof\ \code{#2}}{#1\ \code{#2}} }
+
+% \deftypecvgeneral {subind}category type var args
+%
+\def\deftypecvgeneral#1#2 #3 #4 #5\endheader{%
+ \dosubind{vr}{\code{#4}}{#1}%
+ \defname{#2}{#3}{#4}\defunargs{#5\unskip}%
+}
+
+%%% Untyped variables:
+
+% @defvr category var args
+\makedefun{defvr}#1 {\deftypevrheader{#1} {} }
+
+% @defcv category class var args
+\makedefun{defcv}#1 {\defcvof{#1\ \putwordof}}
+
+% \defcvof {category of}class var args
+\def\defcvof#1#2 {\deftypecvof{#1}#2 {} }
+
+%%% Type:
+% @deftp category name args
+\makedefun{deftp}#1 #2 #3\endheader{%
+ \doind{tp}{\code{#2}}%
+ \defname{#1}{}{#2}\defunargs{#3\unskip}%
+}
+
+% Remaining @defun-like shortcuts:
+\makedefun{defun}{\deffnheader{\putwordDeffunc} }
+\makedefun{defmac}{\deffnheader{\putwordDefmac} }
+\makedefun{defspec}{\deffnheader{\putwordDefspec} }
+\makedefun{deftypefun}{\deftypefnheader{\putwordDeffunc} }
+\makedefun{defvar}{\defvrheader{\putwordDefvar} }
+\makedefun{defopt}{\defvrheader{\putwordDefopt} }
+\makedefun{deftypevar}{\deftypevrheader{\putwordDefvar} }
+\makedefun{defmethod}{\defopon\putwordMethodon}
+\makedefun{deftypemethod}{\deftypeopon\putwordMethodon}
+\makedefun{defivar}{\defcvof\putwordInstanceVariableof}
+\makedefun{deftypeivar}{\deftypecvof\putwordInstanceVariableof}
+
+% \defname, which formats the name of the @def (not the args).
+% #1 is the category, such as "Function".
+% #2 is the return type, if any.
+% #3 is the function name.
+%
+% We are followed by (but not passed) the arguments, if any.
+%
+\def\defname#1#2#3{%
+ % Get the values of \leftskip and \rightskip as they were outside the @def...
+ \advance\leftskip by -\defbodyindent
+ %
+ % How we'll format the type name. Putting it in brackets helps
+ % distinguish it from the body text that may end up on the next line
+ % just below it.
+ \def\temp{#1}%
+ \setbox0=\hbox{\kern\deflastargmargin \ifx\temp\empty\else [\rm\temp]\fi}
+ %
+ % Figure out line sizes for the paragraph shape.
+ % The first line needs space for \box0; but if \rightskip is nonzero,
+ % we need only space for the part of \box0 which exceeds it:
+ \dimen0=\hsize \advance\dimen0 by -\wd0 \advance\dimen0 by \rightskip
+ % The continuations:
+ \dimen2=\hsize \advance\dimen2 by -\defargsindent
+ % (plain.tex says that \dimen1 should be used only as global.)
+ \parshape 2 0in \dimen0 \defargsindent \dimen2
+ %
+ % Put the type name to the right margin.
+ \noindent
+ \hbox to 0pt{%
+ \hfil\box0 \kern-\hsize
+ % \hsize has to be shortened this way:
+ \kern\leftskip
+ % Intentionally do not respect \rightskip, since we need the space.
+ }%
+ %
+ % Allow all lines to be underfull without complaint:
+ \tolerance=10000 \hbadness=10000
+ \exdentamount=\defbodyindent
+ {%
+ % defun fonts. We use typewriter by default (used to be bold) because:
+ % . we're printing identifiers, they should be in tt in principle.
+ % . in languages with many accents, such as Czech or French, it's
+ % common to leave accents off identifiers. The result looks ok in
+ % tt, but exceedingly strange in rm.
+ % . we don't want -- and --- to be treated as ligatures.
+ % . this still does not fix the ?` and !` ligatures, but so far no
+ % one has made identifiers using them :).
+ \df \tt
+ \def\temp{#2}% return value type
+ \ifx\temp\empty\else \tclose{\temp} \fi
+ #3% output function name
+ }%
+ {\rm\enskip}% hskip 0.5 em of \tenrm
+ %
+ \boldbrax
+ % arguments will be output next, if any.
+}
+
+% Print arguments in slanted roman (not ttsl), inconsistently with using
+% tt for the name. This is because literal text is sometimes needed in
+% the argument list (groff manual), and ttsl and tt are not very
+% distinguishable. Prevent hyphenation at `-' chars.
+%
+\def\defunargs#1{%
+ % use sl by default (not ttsl),
+ % tt for the names.
+ \df \sl \hyphenchar\font=0
+ %
+ % On the other hand, if an argument has two dashes (for instance), we
+ % want a way to get ttsl. Let's try @var for that.
+ \let\var=\ttslanted
+ #1%
+ \sl\hyphenchar\font=45
+}
+
+% We want ()&[] to print specially on the defun line.
+%
+\def\activeparens{%
+ \catcode`\(=\active \catcode`\)=\active
+ \catcode`\[=\active \catcode`\]=\active
+ \catcode`\&=\active
+}
+
+% Make control sequences which act like normal parenthesis chars.
+\let\lparen = ( \let\rparen = )
+
+% Be sure that we always have a definition for `(', etc. For example,
+% if the fn name has parens in it, \boldbrax will not be in effect yet,
+% so TeX would otherwise complain about undefined control sequence.
+{
+ \activeparens
+ \global\let(=\lparen \global\let)=\rparen
+ \global\let[=\lbrack \global\let]=\rbrack
+ \global\let& = \&
+
+ \gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb}
+ \gdef\magicamp{\let&=\amprm}
+}
+
+\newcount\parencount
+
+% If we encounter &foo, then turn on ()-hacking afterwards
+\newif\ifampseen
+\def\amprm#1 {\ampseentrue{\bf\ }}
+
+\def\parenfont{%
+ \ifampseen
+ % At the first level, print parens in roman,
+ % otherwise use the default font.
+ \ifnum \parencount=1 \rm \fi
+ \else
+ % The \sf parens (in \boldbrax) actually are a little bolder than
+ % the contained text. This is especially needed for [ and ] .
+ \sf
+ \fi
+}
+\def\infirstlevel#1{%
+ \ifampseen
+ \ifnum\parencount=1
+ #1%
+ \fi
+ \fi
+}
+\def\bfafterword#1 {#1 \bf}
+
+\def\opnr{%
+ \global\advance\parencount by 1
+ {\parenfont(}%
+ \infirstlevel \bfafterword
+}
+\def\clnr{%
+ {\parenfont)}%
+ \infirstlevel \sl
+ \global\advance\parencount by -1
+}
+
+\newcount\brackcount
+\def\lbrb{%
+ \global\advance\brackcount by 1
+ {\bf[}%
+}
+\def\rbrb{%
+ {\bf]}%
+ \global\advance\brackcount by -1
+}
+
+\def\checkparencounts{%
+ \ifnum\parencount=0 \else \badparencount \fi
+ \ifnum\brackcount=0 \else \badbrackcount \fi
+}
+% these should not use \errmessage; the glibc manual, at least, actually
+% has such constructs (when documenting function pointers).
+\def\badparencount{%
+ \message{Warning: unbalanced parentheses in @def...}%
+ \global\parencount=0
+}
+\def\badbrackcount{%
+ \message{Warning: unbalanced square brackets in @def...}%
+ \global\brackcount=0
+}
+
+
+\message{macros,}
+% @macro.
+
+% To do this right we need a feature of e-TeX, \scantokens,
+% which we arrange to emulate with a temporary file in ordinary TeX.
+\ifx\eTeXversion\undefined
+ \newwrite\macscribble
+ \def\scantokens#1{%
+ \toks0={#1}%
+ \immediate\openout\macscribble=\jobname.tmp
+ \immediate\write\macscribble{\the\toks0}%
+ \immediate\closeout\macscribble
+ \input \jobname.tmp
+ }
+\fi
+
+\def\scanmacro#1{%
+ \begingroup
+ \newlinechar`\^^M
+ \let\xeatspaces\eatspaces
+ % Undo catcode changes of \startcontents and \doprintindex
+ % When called from @insertcopying or (short)caption, we need active
+ % backslash to get it printed correctly. Previously, we had
+ % \catcode`\\=\other instead. We'll see whether a problem appears
+ % with macro expansion. --kasal, 19aug04
+ \catcode`\@=0 \catcode`\\=\active \escapechar=`\@
+ % ... and \example
+ \spaceisspace
+ %
+ % Append \endinput to make sure that TeX does not see the ending newline.
+ % I've verified that it is necessary both for e-TeX and for ordinary TeX
+ % --kasal, 29nov03
+ \scantokens{#1\endinput}%
+ \endgroup
+}
+
+\def\scanexp#1{%
+ \edef\temp{\noexpand\scanmacro{#1}}%
+ \temp
+}
+
+\newcount\paramno % Count of parameters
+\newtoks\macname % Macro name
+\newif\ifrecursive % Is it recursive?
+
+% List of all defined macros in the form
+% \definedummyword\macro1\definedummyword\macro2...
+% Currently is also contains all @aliases; the list can be split
+% if there is a need.
+\def\macrolist{}
+
+% Add the macro to \macrolist
+\def\addtomacrolist#1{\expandafter \addtomacrolistxxx \csname#1\endcsname}
+\def\addtomacrolistxxx#1{%
+ \toks0 = \expandafter{\macrolist\definedummyword#1}%
+ \xdef\macrolist{\the\toks0}%
+}
+
+% Utility routines.
+% This does \let #1 = #2, with \csnames; that is,
+% \let \csname#1\endcsname = \csname#2\endcsname
+% (except of course we have to play expansion games).
+%
+\def\cslet#1#2{%
+ \expandafter\let
+ \csname#1\expandafter\endcsname
+ \csname#2\endcsname
+}
+
+% Trim leading and trailing spaces off a string.
+% Concepts from aro-bend problem 15 (see CTAN).
+{\catcode`\@=11
+\gdef\eatspaces #1{\expandafter\trim@\expandafter{#1 }}
+\gdef\trim@ #1{\trim@@ @#1 @ #1 @ @@}
+\gdef\trim@@ #1@ #2@ #3@@{\trim@@@\empty #2 @}
+\def\unbrace#1{#1}
+\unbrace{\gdef\trim@@@ #1 } #2@{#1}
+}
+
+% Trim a single trailing ^^M off a string.
+{\catcode`\^^M=\other \catcode`\Q=3%
+\gdef\eatcr #1{\eatcra #1Q^^MQ}%
+\gdef\eatcra#1^^MQ{\eatcrb#1Q}%
+\gdef\eatcrb#1Q#2Q{#1}%
+}
+
+% Macro bodies are absorbed as an argument in a context where
+% all characters are catcode 10, 11 or 12, except \ which is active
+% (as in normal texinfo). It is necessary to change the definition of \.
+
+% Non-ASCII encodings make 8-bit characters active, so un-activate
+% them to avoid their expansion. Must do this non-globally, to
+% confine the change to the current group.
+
+% It's necessary to have hard CRs when the macro is executed. This is
+% done by making ^^M (\endlinechar) catcode 12 when reading the macro
+% body, and then making it the \newlinechar in \scanmacro.
+
+\def\scanctxt{%
+ \catcode`\"=\other
+ \catcode`\+=\other
+ \catcode`\<=\other
+ \catcode`\>=\other
+ \catcode`\@=\other
+ \catcode`\^=\other
+ \catcode`\_=\other
+ \catcode`\|=\other
+ \catcode`\~=\other
+ \ifx\declaredencoding\ascii \else \setnonasciicharscatcodenonglobal\other \fi
+}
+
+\def\scanargctxt{%
+ \scanctxt
+ \catcode`\\=\other
+ \catcode`\^^M=\other
+}
+
+\def\macrobodyctxt{%
+ \scanctxt
+ \catcode`\{=\other
+ \catcode`\}=\other
+ \catcode`\^^M=\other
+ \usembodybackslash
+}
+
+\def\macroargctxt{%
+ \scanctxt
+ \catcode`\\=\other
+}
+
+% \mbodybackslash is the definition of \ in @macro bodies.
+% It maps \foo\ => \csname macarg.foo\endcsname => #N
+% where N is the macro parameter number.
+% We define \csname macarg.\endcsname to be \realbackslash, so
+% \\ in macro replacement text gets you a backslash.
+
+{\catcode`@=0 @catcode`@\=@active
+ @gdef@usembodybackslash{@let\=@mbodybackslash}
+ @gdef@mbodybackslash#1\{@csname macarg.#1@endcsname}
+}
+\expandafter\def\csname macarg.\endcsname{\realbackslash}
+
+\def\macro{\recursivefalse\parsearg\macroxxx}
+\def\rmacro{\recursivetrue\parsearg\macroxxx}
+
+\def\macroxxx#1{%
+ \getargs{#1}% now \macname is the macname and \argl the arglist
+ \ifx\argl\empty % no arguments
+ \paramno=0%
+ \else
+ \expandafter\parsemargdef \argl;%
+ \fi
+ \if1\csname ismacro.\the\macname\endcsname
+ \message{Warning: redefining \the\macname}%
+ \else
+ \expandafter\ifx\csname \the\macname\endcsname \relax
+ \else \errmessage{Macro name \the\macname\space already defined}\fi
+ \global\cslet{macsave.\the\macname}{\the\macname}%
+ \global\expandafter\let\csname ismacro.\the\macname\endcsname=1%
+ \addtomacrolist{\the\macname}%
+ \fi
+ \begingroup \macrobodyctxt
+ \ifrecursive \expandafter\parsermacbody
+ \else \expandafter\parsemacbody
+ \fi}
+
+\parseargdef\unmacro{%
+ \if1\csname ismacro.#1\endcsname
+ \global\cslet{#1}{macsave.#1}%
+ \global\expandafter\let \csname ismacro.#1\endcsname=0%
+ % Remove the macro name from \macrolist:
+ \begingroup
+ \expandafter\let\csname#1\endcsname \relax
+ \let\definedummyword\unmacrodo
+ \xdef\macrolist{\macrolist}%
+ \endgroup
+ \else
+ \errmessage{Macro #1 not defined}%
+ \fi
+}
+
+% Called by \do from \dounmacro on each macro. The idea is to omit any
+% macro definitions that have been changed to \relax.
+%
+\def\unmacrodo#1{%
+ \ifx #1\relax
+ % remove this
+ \else
+ \noexpand\definedummyword \noexpand#1%
+ \fi
+}
+
+% This makes use of the obscure feature that if the last token of a
+% <parameter list> is #, then the preceding argument is delimited by
+% an opening brace, and that opening brace is not consumed.
+\def\getargs#1{\getargsxxx#1{}}
+\def\getargsxxx#1#{\getmacname #1 \relax\getmacargs}
+\def\getmacname #1 #2\relax{\macname={#1}}
+\def\getmacargs#1{\def\argl{#1}}
+
+% Parse the optional {params} list. Set up \paramno and \paramlist
+% so \defmacro knows what to do. Define \macarg.blah for each blah
+% in the params list, to be ##N where N is the position in that list.
+% That gets used by \mbodybackslash (above).
+
+% We need to get `macro parameter char #' into several definitions.
+% The technique used is stolen from LaTeX: let \hash be something
+% unexpandable, insert that wherever you need a #, and then redefine
+% it to # just before using the token list produced.
+%
+% The same technique is used to protect \eatspaces till just before
+% the macro is used.
+
+\def\parsemargdef#1;{\paramno=0\def\paramlist{}%
+ \let\hash\relax\let\xeatspaces\relax\parsemargdefxxx#1,;,}
+\def\parsemargdefxxx#1,{%
+ \if#1;\let\next=\relax
+ \else \let\next=\parsemargdefxxx
+ \advance\paramno by 1%
+ \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname
+ {\xeatspaces{\hash\the\paramno}}%
+ \edef\paramlist{\paramlist\hash\the\paramno,}%
+ \fi\next}
+
+% These two commands read recursive and nonrecursive macro bodies.
+% (They're different since rec and nonrec macros end differently.)
+
+\long\def\parsemacbody#1@end macro%
+{\xdef\temp{\eatcr{#1}}\endgroup\defmacro}%
+\long\def\parsermacbody#1@end rmacro%
+{\xdef\temp{\eatcr{#1}}\endgroup\defmacro}%
+
+% This defines the macro itself. There are six cases: recursive and
+% nonrecursive macros of zero, one, and many arguments.
+% Much magic with \expandafter here.
+% \xdef is used so that macro definitions will survive the file
+% they're defined in; @include reads the file inside a group.
+\def\defmacro{%
+ \let\hash=##% convert placeholders to macro parameter chars
+ \ifrecursive
+ \ifcase\paramno
+ % 0
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \noexpand\scanmacro{\temp}}%
+ \or % 1
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup\noexpand\macroargctxt
+ \noexpand\braceorline
+ \expandafter\noexpand\csname\the\macname xxx\endcsname}%
+ \expandafter\xdef\csname\the\macname xxx\endcsname##1{%
+ \egroup\noexpand\scanmacro{\temp}}%
+ \else % many
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup\noexpand\macroargctxt
+ \noexpand\csname\the\macname xx\endcsname}%
+ \expandafter\xdef\csname\the\macname xx\endcsname##1{%
+ \expandafter\noexpand\csname\the\macname xxx\endcsname ##1,}%
+ \expandafter\expandafter
+ \expandafter\xdef
+ \expandafter\expandafter
+ \csname\the\macname xxx\endcsname
+ \paramlist{\egroup\noexpand\scanmacro{\temp}}%
+ \fi
+ \else
+ \ifcase\paramno
+ % 0
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \noexpand\norecurse{\the\macname}%
+ \noexpand\scanmacro{\temp}\egroup}%
+ \or % 1
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup\noexpand\macroargctxt
+ \noexpand\braceorline
+ \expandafter\noexpand\csname\the\macname xxx\endcsname}%
+ \expandafter\xdef\csname\the\macname xxx\endcsname##1{%
+ \egroup
+ \noexpand\norecurse{\the\macname}%
+ \noexpand\scanmacro{\temp}\egroup}%
+ \else % many
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup\noexpand\macroargctxt
+ \expandafter\noexpand\csname\the\macname xx\endcsname}%
+ \expandafter\xdef\csname\the\macname xx\endcsname##1{%
+ \expandafter\noexpand\csname\the\macname xxx\endcsname ##1,}%
+ \expandafter\expandafter
+ \expandafter\xdef
+ \expandafter\expandafter
+ \csname\the\macname xxx\endcsname
+ \paramlist{%
+ \egroup
+ \noexpand\norecurse{\the\macname}%
+ \noexpand\scanmacro{\temp}\egroup}%
+ \fi
+ \fi}
+
+\def\norecurse#1{\bgroup\cslet{#1}{macsave.#1}}
+
+% \braceorline decides whether the next nonwhitespace character is a
+% {. If so it reads up to the closing }, if not, it reads the whole
+% line. Whatever was read is then fed to the next control sequence
+% as an argument (by \parsebrace or \parsearg)
+\def\braceorline#1{\let\macnamexxx=#1\futurelet\nchar\braceorlinexxx}
+\def\braceorlinexxx{%
+ \ifx\nchar\bgroup\else
+ \expandafter\parsearg
+ \fi \macnamexxx}
+
+
+% @alias.
+% We need some trickery to remove the optional spaces around the equal
+% sign. Just make them active and then expand them all to nothing.
+\def\alias{\parseargusing\obeyspaces\aliasxxx}
+\def\aliasxxx #1{\aliasyyy#1\relax}
+\def\aliasyyy #1=#2\relax{%
+ {%
+ \expandafter\let\obeyedspace=\empty
+ \addtomacrolist{#1}%
+ \xdef\next{\global\let\makecsname{#1}=\makecsname{#2}}%
+ }%
+ \next
+}
+
+
+\message{cross references,}
+
+\newwrite\auxfile
+\newif\ifhavexrefs % True if xref values are known.
+\newif\ifwarnedxrefs % True if we warned once that they aren't known.
+
+% @inforef is relatively simple.
+\def\inforef #1{\inforefzzz #1,,,,**}
+\def\inforefzzz #1,#2,#3,#4**{\putwordSee{} \putwordInfo{} \putwordfile{} \file{\ignorespaces #3{}},
+ node \samp{\ignorespaces#1{}}}
+
+% @node's only job in TeX is to define \lastnode, which is used in
+% cross-references. The @node line might or might not have commas, and
+% might or might not have spaces before the first comma, like:
+% @node foo , bar , ...
+% We don't want such trailing spaces in the node name.
+%
+\parseargdef\node{\checkenv{}\donode #1 ,\finishnodeparse}
+%
+% also remove a trailing comma, in case of something like this:
+% @node Help-Cross, , , Cross-refs
+\def\donode#1 ,#2\finishnodeparse{\dodonode #1,\finishnodeparse}
+\def\dodonode#1,#2\finishnodeparse{\gdef\lastnode{#1}}
+
+\let\nwnode=\node
+\let\lastnode=\empty
+
+% Write a cross-reference definition for the current node. #1 is the
+% type (Ynumbered, Yappendix, Ynothing).
+%
+\def\donoderef#1{%
+ \ifx\lastnode\empty\else
+ \setref{\lastnode}{#1}%
+ \global\let\lastnode=\empty
+ \fi
+}
+
+% @anchor{NAME} -- define xref target at arbitrary point.
+%
+\newcount\savesfregister
+%
+\def\savesf{\relax \ifhmode \savesfregister=\spacefactor \fi}
+\def\restoresf{\relax \ifhmode \spacefactor=\savesfregister \fi}
+\def\anchor#1{\savesf \setref{#1}{Ynothing}\restoresf \ignorespaces}
+
+% \setref{NAME}{SNT} defines a cross-reference point NAME (a node or an
+% anchor), which consists of three parts:
+% 1) NAME-title - the current sectioning name taken from \lastsection,
+% or the anchor name.
+% 2) NAME-snt - section number and type, passed as the SNT arg, or
+% empty for anchors.
+% 3) NAME-pg - the page number.
+%
+% This is called from \donoderef, \anchor, and \dofloat. In the case of
+% floats, there is an additional part, which is not written here:
+% 4) NAME-lof - the text as it should appear in a @listoffloats.
+%
+\def\setref#1#2{%
+ \pdfmkdest{#1}%
+ \iflinks
+ {%
+ \atdummies % preserve commands, but don't expand them
+ \edef\writexrdef##1##2{%
+ \write\auxfile{@xrdef{#1-% #1 of \setref, expanded by the \edef
+ ##1}{##2}}% these are parameters of \writexrdef
+ }%
+ \toks0 = \expandafter{\lastsection}%
+ \immediate \writexrdef{title}{\the\toks0 }%
+ \immediate \writexrdef{snt}{\csname #2\endcsname}% \Ynumbered etc.
+ \safewhatsit{\writexrdef{pg}{\folio}}% will be written later, during \shipout
+ }%
+ \fi
+}
+
+% @xref, @pxref, and @ref generate cross-references. For \xrefX, #1 is
+% the node name, #2 the name of the Info cross-reference, #3 the printed
+% node name, #4 the name of the Info file, #5 the name of the printed
+% manual. All but the node name can be omitted.
+%
+\def\pxref#1{\putwordsee{} \xrefX[#1,,,,,,,]}
+\def\xref#1{\putwordSee{} \xrefX[#1,,,,,,,]}
+\def\ref#1{\xrefX[#1,,,,,,,]}
+\def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup
+ \unsepspaces
+ \def\printedmanual{\ignorespaces #5}%
+ \def\printedrefname{\ignorespaces #3}%
+ \setbox1=\hbox{\printedmanual\unskip}%
+ \setbox0=\hbox{\printedrefname\unskip}%
+ \ifdim \wd0 = 0pt
+ % No printed node name was explicitly given.
+ \expandafter\ifx\csname SETxref-automatic-section-title\endcsname\relax
+ % Use the node name inside the square brackets.
+ \def\printedrefname{\ignorespaces #1}%
+ \else
+ % Use the actual chapter/section title appear inside
+ % the square brackets. Use the real section title if we have it.
+ \ifdim \wd1 > 0pt
+ % It is in another manual, so we don't have it.
+ \def\printedrefname{\ignorespaces #1}%
+ \else
+ \ifhavexrefs
+ % We know the real title if we have the xref values.
+ \def\printedrefname{\refx{#1-title}{}}%
+ \else
+ % Otherwise just copy the Info node name.
+ \def\printedrefname{\ignorespaces #1}%
+ \fi%
+ \fi
+ \fi
+ \fi
+ %
+ % Make link in pdf output.
+ \ifpdf
+ \leavevmode
+ \getfilename{#4}%
+ {\indexnofonts
+ \turnoffactive
+ % See comments at \activebackslashdouble.
+ {\activebackslashdouble \xdef\pdfxrefdest{#1}%
+ \backslashparens\pdfxrefdest}%
+ %
+ \ifnum\filenamelength>0
+ \startlink attr{/Border [0 0 0]}%
+ goto file{\the\filename.pdf} name{\pdfxrefdest}%
+ \else
+ \startlink attr{/Border [0 0 0]}%
+ goto name{\pdfmkpgn{\pdfxrefdest}}%
+ \fi
+ }%
+ \setcolor{\linkcolor}%
+ \fi
+ %
+ % Float references are printed completely differently: "Figure 1.2"
+ % instead of "[somenode], p.3". We distinguish them by the
+ % LABEL-title being set to a magic string.
+ {%
+ % Have to otherify everything special to allow the \csname to
+ % include an _ in the xref name, etc.
+ \indexnofonts
+ \turnoffactive
+ \expandafter\global\expandafter\let\expandafter\Xthisreftitle
+ \csname XR#1-title\endcsname
+ }%
+ \iffloat\Xthisreftitle
+ % If the user specified the print name (third arg) to the ref,
+ % print it instead of our usual "Figure 1.2".
+ \ifdim\wd0 = 0pt
+ \refx{#1-snt}{}%
+ \else
+ \printedrefname
+ \fi
+ %
+ % if the user also gave the printed manual name (fifth arg), append
+ % "in MANUALNAME".
+ \ifdim \wd1 > 0pt
+ \space \putwordin{} \cite{\printedmanual}%
+ \fi
+ \else
+ % node/anchor (non-float) references.
+ %
+ % If we use \unhbox0 and \unhbox1 to print the node names, TeX does not
+ % insert empty discretionaries after hyphens, which means that it will
+ % not find a line break at a hyphen in a node names. Since some manuals
+ % are best written with fairly long node names, containing hyphens, this
+ % is a loss. Therefore, we give the text of the node name again, so it
+ % is as if TeX is seeing it for the first time.
+ \ifdim \wd1 > 0pt
+ \putwordSection{} ``\printedrefname'' \putwordin{} \cite{\printedmanual}%
+ \else
+ % _ (for example) has to be the character _ for the purposes of the
+ % control sequence corresponding to the node, but it has to expand
+ % into the usual \leavevmode...\vrule stuff for purposes of
+ % printing. So we \turnoffactive for the \refx-snt, back on for the
+ % printing, back off for the \refx-pg.
+ {\turnoffactive
+ % Only output a following space if the -snt ref is nonempty; for
+ % @unnumbered and @anchor, it won't be.
+ \setbox2 = \hbox{\ignorespaces \refx{#1-snt}{}}%
+ \ifdim \wd2 > 0pt \refx{#1-snt}\space\fi
+ }%
+ % output the `[mynode]' via a macro so it can be overridden.
+ \xrefprintnodename\printedrefname
+ %
+ % But we always want a comma and a space:
+ ,\space
+ %
+ % output the `page 3'.
+ \turnoffactive \putwordpage\tie\refx{#1-pg}{}%
+ \fi
+ \fi
+ \endlink
+\endgroup}
+
+% This macro is called from \xrefX for the `[nodename]' part of xref
+% output. It's a separate macro only so it can be changed more easily,
+% since square brackets don't work well in some documents. Particularly
+% one that Bob is working on :).
+%
+\def\xrefprintnodename#1{[#1]}
+
+% Things referred to by \setref.
+%
+\def\Ynothing{}
+\def\Yomitfromtoc{}
+\def\Ynumbered{%
+ \ifnum\secno=0
+ \putwordChapter@tie \the\chapno
+ \else \ifnum\subsecno=0
+ \putwordSection@tie \the\chapno.\the\secno
+ \else \ifnum\subsubsecno=0
+ \putwordSection@tie \the\chapno.\the\secno.\the\subsecno
+ \else
+ \putwordSection@tie \the\chapno.\the\secno.\the\subsecno.\the\subsubsecno
+ \fi\fi\fi
+}
+\def\Yappendix{%
+ \ifnum\secno=0
+ \putwordAppendix@tie @char\the\appendixno{}%
+ \else \ifnum\subsecno=0
+ \putwordSection@tie @char\the\appendixno.\the\secno
+ \else \ifnum\subsubsecno=0
+ \putwordSection@tie @char\the\appendixno.\the\secno.\the\subsecno
+ \else
+ \putwordSection@tie
+ @char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno
+ \fi\fi\fi
+}
+
+% Define \refx{NAME}{SUFFIX} to reference a cross-reference string named NAME.
+% If its value is nonempty, SUFFIX is output afterward.
+%
+\def\refx#1#2{%
+ {%
+ \indexnofonts
+ \otherbackslash
+ \expandafter\global\expandafter\let\expandafter\thisrefX
+ \csname XR#1\endcsname
+ }%
+ \ifx\thisrefX\relax
+ % If not defined, say something at least.
+ \angleleft un\-de\-fined\angleright
+ \iflinks
+ \ifhavexrefs
+ \message{\linenumber Undefined cross reference `#1'.}%
+ \else
+ \ifwarnedxrefs\else
+ \global\warnedxrefstrue
+ \message{Cross reference values unknown; you must run TeX again.}%
+ \fi
+ \fi
+ \fi
+ \else
+ % It's defined, so just use it.
+ \thisrefX
+ \fi
+ #2% Output the suffix in any case.
+}
+
+% This is the macro invoked by entries in the aux file. Usually it's
+% just a \def (we prepend XR to the control sequence name to avoid
+% collisions). But if this is a float type, we have more work to do.
+%
+\def\xrdef#1#2{%
+ {% The node name might contain 8-bit characters, which in our current
+ % implementation are changed to commands like @'e. Don't let these
+ % mess up the control sequence name.
+ \indexnofonts
+ \turnoffactive
+ \xdef\safexrefname{#1}%
+ }%
+ %
+ \expandafter\gdef\csname XR\safexrefname\endcsname{#2}% remember this xref
+ %
+ % Was that xref control sequence that we just defined for a float?
+ \expandafter\iffloat\csname XR\safexrefname\endcsname
+ % it was a float, and we have the (safe) float type in \iffloattype.
+ \expandafter\let\expandafter\floatlist
+ \csname floatlist\iffloattype\endcsname
+ %
+ % Is this the first time we've seen this float type?
+ \expandafter\ifx\floatlist\relax
+ \toks0 = {\do}% yes, so just \do
+ \else
+ % had it before, so preserve previous elements in list.
+ \toks0 = \expandafter{\floatlist\do}%
+ \fi
+ %
+ % Remember this xref in the control sequence \floatlistFLOATTYPE,
+ % for later use in \listoffloats.
+ \expandafter\xdef\csname floatlist\iffloattype\endcsname{\the\toks0
+ {\safexrefname}}%
+ \fi
+}
+
+% Read the last existing aux file, if any. No error if none exists.
+%
+\def\tryauxfile{%
+ \openin 1 \jobname.aux
+ \ifeof 1 \else
+ \readdatafile{aux}%
+ \global\havexrefstrue
+ \fi
+ \closein 1
+}
+
+\def\setupdatafile{%
+ \catcode`\^^@=\other
+ \catcode`\^^A=\other
+ \catcode`\^^B=\other
+ \catcode`\^^C=\other
+ \catcode`\^^D=\other
+ \catcode`\^^E=\other
+ \catcode`\^^F=\other
+ \catcode`\^^G=\other
+ \catcode`\^^H=\other
+ \catcode`\^^K=\other
+ \catcode`\^^L=\other
+ \catcode`\^^N=\other
+ \catcode`\^^P=\other
+ \catcode`\^^Q=\other
+ \catcode`\^^R=\other
+ \catcode`\^^S=\other
+ \catcode`\^^T=\other
+ \catcode`\^^U=\other
+ \catcode`\^^V=\other
+ \catcode`\^^W=\other
+ \catcode`\^^X=\other
+ \catcode`\^^Z=\other
+ \catcode`\^^[=\other
+ \catcode`\^^\=\other
+ \catcode`\^^]=\other
+ \catcode`\^^^=\other
+ \catcode`\^^_=\other
+ % It was suggested to set the catcode of ^ to 7, which would allow ^^e4 etc.
+ % in xref tags, i.e., node names. But since ^^e4 notation isn't
+ % supported in the main text, it doesn't seem desirable. Furthermore,
+ % that is not enough: for node names that actually contain a ^
+ % character, we would end up writing a line like this: 'xrdef {'hat
+ % b-title}{'hat b} and \xrdef does a \csname...\endcsname on the first
+ % argument, and \hat is not an expandable control sequence. It could
+ % all be worked out, but why? Either we support ^^ or we don't.
+ %
+ % The other change necessary for this was to define \auxhat:
+ % \def\auxhat{\def^{'hat }}% extra space so ok if followed by letter
+ % and then to call \auxhat in \setq.
+ %
+ \catcode`\^=\other
+ %
+ % Special characters. Should be turned off anyway, but...
+ \catcode`\~=\other
+ \catcode`\[=\other
+ \catcode`\]=\other
+ \catcode`\"=\other
+ \catcode`\_=\other
+ \catcode`\|=\other
+ \catcode`\<=\other
+ \catcode`\>=\other
+ \catcode`\$=\other
+ \catcode`\#=\other
+ \catcode`\&=\other
+ \catcode`\%=\other
+ \catcode`+=\other % avoid \+ for paranoia even though we've turned it off
+ %
+ % This is to support \ in node names and titles, since the \
+ % characters end up in a \csname. It's easier than
+ % leaving it active and making its active definition an actual \
+ % character. What I don't understand is why it works in the *value*
+ % of the xrdef. Seems like it should be a catcode12 \, and that
+ % should not typeset properly. But it works, so I'm moving on for
+ % now. --karl, 15jan04.
+ \catcode`\\=\other
+ %
+ % Make the characters 128-255 be printing characters.
+ {%
+ \count1=128
+ \def\loop{%
+ \catcode\count1=\other
+ \advance\count1 by 1
+ \ifnum \count1<256 \loop \fi
+ }%
+ }%
+ %
+ % @ is our escape character in .aux files, and we need braces.
+ \catcode`\{=1
+ \catcode`\}=2
+ \catcode`\@=0
+}
+
+\def\readdatafile#1{%
+\begingroup
+ \setupdatafile
+ \input\jobname.#1
+\endgroup}
+
+
+\message{insertions,}
+% including footnotes.
+
+\newcount \footnoteno
+
+% The trailing space in the following definition for supereject is
+% vital for proper filling; pages come out unaligned when you do a
+% pagealignmacro call if that space before the closing brace is
+% removed. (Generally, numeric constants should always be followed by a
+% space to prevent strange expansion errors.)
+\def\supereject{\par\penalty -20000\footnoteno =0 }
+
+% @footnotestyle is meaningful for info output only.
+\let\footnotestyle=\comment
+
+{\catcode `\@=11
+%
+% Auto-number footnotes. Otherwise like plain.
+\gdef\footnote{%
+ \let\indent=\ptexindent
+ \let\noindent=\ptexnoindent
+ \global\advance\footnoteno by \@ne
+ \edef\thisfootno{$^{\the\footnoteno}$}%
+ %
+ % In case the footnote comes at the end of a sentence, preserve the
+ % extra spacing after we do the footnote number.
+ \let\@sf\empty
+ \ifhmode\edef\@sf{\spacefactor\the\spacefactor}\ptexslash\fi
+ %
+ % Remove inadvertent blank space before typesetting the footnote number.
+ \unskip
+ \thisfootno\@sf
+ \dofootnote
+}%
+
+% Don't bother with the trickery in plain.tex to not require the
+% footnote text as a parameter. Our footnotes don't need to be so general.
+%
+% Oh yes, they do; otherwise, @ifset (and anything else that uses
+% \parseargline) fails inside footnotes because the tokens are fixed when
+% the footnote is read. --karl, 16nov96.
+%
+\gdef\dofootnote{%
+ \insert\footins\bgroup
+ % We want to typeset this text as a normal paragraph, even if the
+ % footnote reference occurs in (for example) a display environment.
+ % So reset some parameters.
+ \hsize=\pagewidth
+ \interlinepenalty\interfootnotelinepenalty
+ \splittopskip\ht\strutbox % top baseline for broken footnotes
+ \splitmaxdepth\dp\strutbox
+ \floatingpenalty\@MM
+ \leftskip\z@skip
+ \rightskip\z@skip
+ \spaceskip\z@skip
+ \xspaceskip\z@skip
+ \parindent\defaultparindent
+ %
+ \smallfonts \rm
+ %
+ % Because we use hanging indentation in footnotes, a @noindent appears
+ % to exdent this text, so make it be a no-op. makeinfo does not use
+ % hanging indentation so @noindent can still be needed within footnote
+ % text after an @example or the like (not that this is good style).
+ \let\noindent = \relax
+ %
+ % Hang the footnote text off the number. Use \everypar in case the
+ % footnote extends for more than one paragraph.
+ \everypar = {\hang}%
+ \textindent{\thisfootno}%
+ %
+ % Don't crash into the line above the footnote text. Since this
+ % expands into a box, it must come within the paragraph, lest it
+ % provide a place where TeX can split the footnote.
+ \footstrut
+ \futurelet\next\fo@t
+}
+}%end \catcode `\@=11
+
+% In case a @footnote appears in a vbox, save the footnote text and create
+% the real \insert just after the vbox finished. Otherwise, the insertion
+% would be lost.
+% Similarily, if a @footnote appears inside an alignment, save the footnote
+% text to a box and make the \insert when a row of the table is finished.
+% And the same can be done for other insert classes. --kasal, 16nov03.
+
+% Replace the \insert primitive by a cheating macro.
+% Deeper inside, just make sure that the saved insertions are not spilled
+% out prematurely.
+%
+\def\startsavinginserts{%
+ \ifx \insert\ptexinsert
+ \let\insert\saveinsert
+ \else
+ \let\checkinserts\relax
+ \fi
+}
+
+% This \insert replacement works for both \insert\footins{foo} and
+% \insert\footins\bgroup foo\egroup, but it doesn't work for \insert27{foo}.
+%
+\def\saveinsert#1{%
+ \edef\next{\noexpand\savetobox \makeSAVEname#1}%
+ \afterassignment\next
+ % swallow the left brace
+ \let\temp =
+}
+\def\makeSAVEname#1{\makecsname{SAVE\expandafter\gobble\string#1}}
+\def\savetobox#1{\global\setbox#1 = \vbox\bgroup \unvbox#1}
+
+\def\checksaveins#1{\ifvoid#1\else \placesaveins#1\fi}
+
+\def\placesaveins#1{%
+ \ptexinsert \csname\expandafter\gobblesave\string#1\endcsname
+ {\box#1}%
+}
+
+% eat @SAVE -- beware, all of them have catcode \other:
+{
+ \def\dospecials{\do S\do A\do V\do E} \uncatcodespecials % ;-)
+ \gdef\gobblesave @SAVE{}
+}
+
+% initialization:
+\def\newsaveins #1{%
+ \edef\next{\noexpand\newsaveinsX \makeSAVEname#1}%
+ \next
+}
+\def\newsaveinsX #1{%
+ \csname newbox\endcsname #1%
+ \expandafter\def\expandafter\checkinserts\expandafter{\checkinserts
+ \checksaveins #1}%
+}
+
+% initialize:
+\let\checkinserts\empty
+\newsaveins\footins
+\newsaveins\margin
+
+
+% @image. We use the macros from epsf.tex to support this.
+% If epsf.tex is not installed and @image is used, we complain.
+%
+% Check for and read epsf.tex up front. If we read it only at @image
+% time, we might be inside a group, and then its definitions would get
+% undone and the next image would fail.
+\openin 1 = epsf.tex
+\ifeof 1 \else
+ % Do not bother showing banner with epsf.tex v2.7k (available in
+ % doc/epsf.tex and on ctan).
+ \def\epsfannounce{\toks0 = }%
+ \input epsf.tex
+\fi
+\closein 1
+%
+% We will only complain once about lack of epsf.tex.
+\newif\ifwarnednoepsf
+\newhelp\noepsfhelp{epsf.tex must be installed for images to
+ work. It is also included in the Texinfo distribution, or you can get
+ it from ftp://tug.org/tex/epsf.tex.}
+%
+\def\image#1{%
+ \ifx\epsfbox\undefined
+ \ifwarnednoepsf \else
+ \errhelp = \noepsfhelp
+ \errmessage{epsf.tex not found, images will be ignored}%
+ \global\warnednoepsftrue
+ \fi
+ \else
+ \imagexxx #1,,,,,\finish
+ \fi
+}
+%
+% Arguments to @image:
+% #1 is (mandatory) image filename; we tack on .eps extension.
+% #2 is (optional) width, #3 is (optional) height.
+% #4 is (ignored optional) html alt text.
+% #5 is (ignored optional) extension.
+% #6 is just the usual extra ignored arg for parsing this stuff.
+\newif\ifimagevmode
+\def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup
+ \catcode`\^^M = 5 % in case we're inside an example
+ \normalturnoffactive % allow _ et al. in names
+ % If the image is by itself, center it.
+ \ifvmode
+ \imagevmodetrue
+ \nobreak\bigskip
+ % Usually we'll have text after the image which will insert
+ % \parskip glue, so insert it here too to equalize the space
+ % above and below.
+ \nobreak\vskip\parskip
+ \nobreak
+ \line\bgroup
+ \fi
+ %
+ % Output the image.
+ \ifpdf
+ \dopdfimage{#1}{#2}{#3}%
+ \else
+ % \epsfbox itself resets \epsf?size at each figure.
+ \setbox0 = \hbox{\ignorespaces #2}\ifdim\wd0 > 0pt \epsfxsize=#2\relax \fi
+ \setbox0 = \hbox{\ignorespaces #3}\ifdim\wd0 > 0pt \epsfysize=#3\relax \fi
+ \epsfbox{#1.eps}%
+ \fi
+ %
+ \ifimagevmode \egroup \bigbreak \fi % space after the image
+\endgroup}
+
+
+% @float FLOATTYPE,LABEL,LOC ... @end float for displayed figures, tables,
+% etc. We don't actually implement floating yet, we always include the
+% float "here". But it seemed the best name for the future.
+%
+\envparseargdef\float{\eatcommaspace\eatcommaspace\dofloat#1, , ,\finish}
+
+% There may be a space before second and/or third parameter; delete it.
+\def\eatcommaspace#1, {#1,}
+
+% #1 is the optional FLOATTYPE, the text label for this float, typically
+% "Figure", "Table", "Example", etc. Can't contain commas. If omitted,
+% this float will not be numbered and cannot be referred to.
+%
+% #2 is the optional xref label. Also must be present for the float to
+% be referable.
+%
+% #3 is the optional positioning argument; for now, it is ignored. It
+% will somehow specify the positions allowed to float to (here, top, bottom).
+%
+% We keep a separate counter for each FLOATTYPE, which we reset at each
+% chapter-level command.
+\let\resetallfloatnos=\empty
+%
+\def\dofloat#1,#2,#3,#4\finish{%
+ \let\thiscaption=\empty
+ \let\thisshortcaption=\empty
+ %
+ % don't lose footnotes inside @float.
+ %
+ % BEWARE: when the floats start float, we have to issue warning whenever an
+ % insert appears inside a float which could possibly float. --kasal, 26may04
+ %
+ \startsavinginserts
+ %
+ % We can't be used inside a paragraph.
+ \par
+ %
+ \vtop\bgroup
+ \def\floattype{#1}%
+ \def\floatlabel{#2}%
+ \def\floatloc{#3}% we do nothing with this yet.
+ %
+ \ifx\floattype\empty
+ \let\safefloattype=\empty
+ \else
+ {%
+ % the floattype might have accents or other special characters,
+ % but we need to use it in a control sequence name.
+ \indexnofonts
+ \turnoffactive
+ \xdef\safefloattype{\floattype}%
+ }%
+ \fi
+ %
+ % If label is given but no type, we handle that as the empty type.
+ \ifx\floatlabel\empty \else
+ % We want each FLOATTYPE to be numbered separately (Figure 1,
+ % Table 1, Figure 2, ...). (And if no label, no number.)
+ %
+ \expandafter\getfloatno\csname\safefloattype floatno\endcsname
+ \global\advance\floatno by 1
+ %
+ {%
+ % This magic value for \lastsection is output by \setref as the
+ % XREFLABEL-title value. \xrefX uses it to distinguish float
+ % labels (which have a completely different output format) from
+ % node and anchor labels. And \xrdef uses it to construct the
+ % lists of floats.
+ %
+ \edef\lastsection{\floatmagic=\safefloattype}%
+ \setref{\floatlabel}{Yfloat}%
+ }%
+ \fi
+ %
+ % start with \parskip glue, I guess.
+ \vskip\parskip
+ %
+ % Don't suppress indentation if a float happens to start a section.
+ \restorefirstparagraphindent
+}
+
+% we have these possibilities:
+% @float Foo,lbl & @caption{Cap}: Foo 1.1: Cap
+% @float Foo,lbl & no caption: Foo 1.1
+% @float Foo & @caption{Cap}: Foo: Cap
+% @float Foo & no caption: Foo
+% @float ,lbl & Caption{Cap}: 1.1: Cap
+% @float ,lbl & no caption: 1.1
+% @float & @caption{Cap}: Cap
+% @float & no caption:
+%
+\def\Efloat{%
+ \let\floatident = \empty
+ %
+ % In all cases, if we have a float type, it comes first.
+ \ifx\floattype\empty \else \def\floatident{\floattype}\fi
+ %
+ % If we have an xref label, the number comes next.
+ \ifx\floatlabel\empty \else
+ \ifx\floattype\empty \else % if also had float type, need tie first.
+ \appendtomacro\floatident{\tie}%
+ \fi
+ % the number.
+ \appendtomacro\floatident{\chaplevelprefix\the\floatno}%
+ \fi
+ %
+ % Start the printed caption with what we've constructed in
+ % \floatident, but keep it separate; we need \floatident again.
+ \let\captionline = \floatident
+ %
+ \ifx\thiscaption\empty \else
+ \ifx\floatident\empty \else
+ \appendtomacro\captionline{: }% had ident, so need a colon between
+ \fi
+ %
+ % caption text.
+ \appendtomacro\captionline{\scanexp\thiscaption}%
+ \fi
+ %
+ % If we have anything to print, print it, with space before.
+ % Eventually this needs to become an \insert.
+ \ifx\captionline\empty \else
+ \vskip.5\parskip
+ \captionline
+ %
+ % Space below caption.
+ \vskip\parskip
+ \fi
+ %
+ % If have an xref label, write the list of floats info. Do this
+ % after the caption, to avoid chance of it being a breakpoint.
+ \ifx\floatlabel\empty \else
+ % Write the text that goes in the lof to the aux file as
+ % \floatlabel-lof. Besides \floatident, we include the short
+ % caption if specified, else the full caption if specified, else nothing.
+ {%
+ \atdummies
+ %
+ % since we read the caption text in the macro world, where ^^M
+ % is turned into a normal character, we have to scan it back, so
+ % we don't write the literal three characters "^^M" into the aux file.
+ \scanexp{%
+ \xdef\noexpand\gtemp{%
+ \ifx\thisshortcaption\empty
+ \thiscaption
+ \else
+ \thisshortcaption
+ \fi
+ }%
+ }%
+ \immediate\write\auxfile{@xrdef{\floatlabel-lof}{\floatident
+ \ifx\gtemp\empty \else : \gtemp \fi}}%
+ }%
+ \fi
+ \egroup % end of \vtop
+ %
+ % place the captured inserts
+ %
+ % BEWARE: when the floats start floating, we have to issue warning
+ % whenever an insert appears inside a float which could possibly
+ % float. --kasal, 26may04
+ %
+ \checkinserts
+}
+
+% Append the tokens #2 to the definition of macro #1, not expanding either.
+%
+\def\appendtomacro#1#2{%
+ \expandafter\def\expandafter#1\expandafter{#1#2}%
+}
+
+% @caption, @shortcaption
+%
+\def\caption{\docaption\thiscaption}
+\def\shortcaption{\docaption\thisshortcaption}
+\def\docaption{\checkenv\float \bgroup\scanargctxt\defcaption}
+\def\defcaption#1#2{\egroup \def#1{#2}}
+
+% The parameter is the control sequence identifying the counter we are
+% going to use. Create it if it doesn't exist and assign it to \floatno.
+\def\getfloatno#1{%
+ \ifx#1\relax
+ % Haven't seen this figure type before.
+ \csname newcount\endcsname #1%
+ %
+ % Remember to reset this floatno at the next chap.
+ \expandafter\gdef\expandafter\resetallfloatnos
+ \expandafter{\resetallfloatnos #1=0 }%
+ \fi
+ \let\floatno#1%
+}
+
+% \setref calls this to get the XREFLABEL-snt value. We want an @xref
+% to the FLOATLABEL to expand to "Figure 3.1". We call \setref when we
+% first read the @float command.
+%
+\def\Yfloat{\floattype@tie \chaplevelprefix\the\floatno}%
+
+% Magic string used for the XREFLABEL-title value, so \xrefX can
+% distinguish floats from other xref types.
+\def\floatmagic{!!float!!}
+
+% #1 is the control sequence we are passed; we expand into a conditional
+% which is true if #1 represents a float ref. That is, the magic
+% \lastsection value which we \setref above.
+%
+\def\iffloat#1{\expandafter\doiffloat#1==\finish}
+%
+% #1 is (maybe) the \floatmagic string. If so, #2 will be the
+% (safe) float type for this float. We set \iffloattype to #2.
+%
+\def\doiffloat#1=#2=#3\finish{%
+ \def\temp{#1}%
+ \def\iffloattype{#2}%
+ \ifx\temp\floatmagic
+}
+
+% @listoffloats FLOATTYPE - print a list of floats like a table of contents.
+%
+\parseargdef\listoffloats{%
+ \def\floattype{#1}% floattype
+ {%
+ % the floattype might have accents or other special characters,
+ % but we need to use it in a control sequence name.
+ \indexnofonts
+ \turnoffactive
+ \xdef\safefloattype{\floattype}%
+ }%
+ %
+ % \xrdef saves the floats as a \do-list in \floatlistSAFEFLOATTYPE.
+ \expandafter\ifx\csname floatlist\safefloattype\endcsname \relax
+ \ifhavexrefs
+ % if the user said @listoffloats foo but never @float foo.
+ \message{\linenumber No `\safefloattype' floats to list.}%
+ \fi
+ \else
+ \begingroup
+ \leftskip=\tocindent % indent these entries like a toc
+ \let\do=\listoffloatsdo
+ \csname floatlist\safefloattype\endcsname
+ \endgroup
+ \fi
+}
+
+% This is called on each entry in a list of floats. We're passed the
+% xref label, in the form LABEL-title, which is how we save it in the
+% aux file. We strip off the -title and look up \XRLABEL-lof, which
+% has the text we're supposed to typeset here.
+%
+% Figures without xref labels will not be included in the list (since
+% they won't appear in the aux file).
+%
+\def\listoffloatsdo#1{\listoffloatsdoentry#1\finish}
+\def\listoffloatsdoentry#1-title\finish{{%
+ % Can't fully expand XR#1-lof because it can contain anything. Just
+ % pass the control sequence. On the other hand, XR#1-pg is just the
+ % page number, and we want to fully expand that so we can get a link
+ % in pdf output.
+ \toksA = \expandafter{\csname XR#1-lof\endcsname}%
+ %
+ % use the same \entry macro we use to generate the TOC and index.
+ \edef\writeentry{\noexpand\entry{\the\toksA}{\csname XR#1-pg\endcsname}}%
+ \writeentry
+}}
+
+
+\message{localization,}
+
+% @documentlanguage is usually given very early, just after
+% @setfilename. If done too late, it may not override everything
+% properly. Single argument is the language (de) or locale (de_DE)
+% abbreviation. It would be nice if we could set up a hyphenation file.
+%
+{
+ \catcode`\_ = \active
+ \globaldefs=1
+\parseargdef\documentlanguage{\begingroup
+ \let_=\normalunderscore % normal _ character for filenames
+ \tex % read txi-??.tex file in plain TeX.
+ % Read the file by the name they passed if it exists.
+ \openin 1 txi-#1.tex
+ \ifeof 1
+ \documentlanguagetrywithoutunderscore{#1_\finish}%
+ \else
+ \input txi-#1.tex
+ \fi
+ \closein 1
+ \endgroup
+\endgroup}
+}
+%
+% If they passed de_DE, and txi-de_DE.tex doesn't exist,
+% try txi-de.tex.
+%
+\def\documentlanguagetrywithoutunderscore#1_#2\finish{%
+ \openin 1 txi-#1.tex
+ \ifeof 1
+ \errhelp = \nolanghelp
+ \errmessage{Cannot read language file txi-#1.tex}%
+ \else
+ \input txi-#1.tex
+ \fi
+ \closein 1
+}
+%
+\newhelp\nolanghelp{The given language definition file cannot be found or
+is empty. Maybe you need to install it? In the current directory
+should work if nowhere else does.}
+
+% Set the catcode of characters 128 through 255 to the specified number.
+%
+\def\setnonasciicharscatcode#1{%
+ \count255=128
+ \loop\ifnum\count255<256
+ \global\catcode\count255=#1\relax
+ \advance\count255 by 1
+ \repeat
+}
+
+\def\setnonasciicharscatcodenonglobal#1{%
+ \count255=128
+ \loop\ifnum\count255<256
+ \catcode\count255=#1\relax
+ \advance\count255 by 1
+ \repeat
+}
+
+% @documentencoding sets the definition of non-ASCII characters
+% according to the specified encoding.
+%
+\parseargdef\documentencoding{%
+ % Encoding being declared for the document.
+ \def\declaredencoding{\csname #1.enc\endcsname}%
+ %
+ % Supported encodings: names converted to tokens in order to be able
+ % to compare them with \ifx.
+ \def\ascii{\csname US-ASCII.enc\endcsname}%
+ \def\latnine{\csname ISO-8859-15.enc\endcsname}%
+ \def\latone{\csname ISO-8859-1.enc\endcsname}%
+ \def\lattwo{\csname ISO-8859-2.enc\endcsname}%
+ \def\utfeight{\csname UTF-8.enc\endcsname}%
+ %
+ \ifx \declaredencoding \ascii
+ \asciichardefs
+ %
+ \else \ifx \declaredencoding \lattwo
+ \setnonasciicharscatcode\active
+ \lattwochardefs
+ %
+ \else \ifx \declaredencoding \latone
+ \setnonasciicharscatcode\active
+ \latonechardefs
+ %
+ \else \ifx \declaredencoding \latnine
+ \setnonasciicharscatcode\active
+ \latninechardefs
+ %
+ \else \ifx \declaredencoding \utfeight
+ \setnonasciicharscatcode\active
+ \utfeightchardefs
+ %
+ \else
+ \message{Unknown document encoding #1, ignoring.}%
+ %
+ \fi % utfeight
+ \fi % latnine
+ \fi % latone
+ \fi % lattwo
+ \fi % ascii
+}
+
+% A message to be logged when using a character that isn't available
+% the default font encoding (OT1).
+%
+\def\missingcharmsg#1{\message{Character missing in OT1 encoding: #1.}}
+
+% Take account of \c (plain) vs. \, (Texinfo) difference.
+\def\cedilla#1{\ifx\c\ptexc\c{#1}\else\,{#1}\fi}
+
+% First, make active non-ASCII characters in order for them to be
+% correctly categorized when TeX reads the replacement text of
+% macros containing the character definitions.
+\setnonasciicharscatcode\active
+%
+% Latin1 (ISO-8859-1) character definitions.
+\def\latonechardefs{%
+ \gdef^^a0{~}
+ \gdef^^a1{\exclamdown}
+ \gdef^^a2{\missingcharmsg{CENT SIGN}}
+ \gdef^^a3{{\pounds}}
+ \gdef^^a4{\missingcharmsg{CURRENCY SIGN}}
+ \gdef^^a5{\missingcharmsg{YEN SIGN}}
+ \gdef^^a6{\missingcharmsg{BROKEN BAR}}
+ \gdef^^a7{\S}
+ \gdef^^a8{\"{}}
+ \gdef^^a9{\copyright}
+ \gdef^^aa{\ordf}
+ \gdef^^ab{\missingcharmsg{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}}
+ \gdef^^ac{$\lnot$}
+ \gdef^^ad{\-}
+ \gdef^^ae{\registeredsymbol}
+ \gdef^^af{\={}}
+ %
+ \gdef^^b0{\textdegree}
+ \gdef^^b1{$\pm$}
+ \gdef^^b2{$^2$}
+ \gdef^^b3{$^3$}
+ \gdef^^b4{\'{}}
+ \gdef^^b5{$\mu$}
+ \gdef^^b6{\P}
+ %
+ \gdef^^b7{$^.$}
+ \gdef^^b8{\cedilla\ }
+ \gdef^^b9{$^1$}
+ \gdef^^ba{\ordm}
+ %
+ \gdef^^bb{\missingcharmsg{RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK}}
+ \gdef^^bc{$1\over4$}
+ \gdef^^bd{$1\over2$}
+ \gdef^^be{$3\over4$}
+ \gdef^^bf{\questiondown}
+ %
+ \gdef^^c0{\`A}
+ \gdef^^c1{\'A}
+ \gdef^^c2{\^A}
+ \gdef^^c3{\~A}
+ \gdef^^c4{\"A}
+ \gdef^^c5{\ringaccent A}
+ \gdef^^c6{\AE}
+ \gdef^^c7{\cedilla C}
+ \gdef^^c8{\`E}
+ \gdef^^c9{\'E}
+ \gdef^^ca{\^E}
+ \gdef^^cb{\"E}
+ \gdef^^cc{\`I}
+ \gdef^^cd{\'I}
+ \gdef^^ce{\^I}
+ \gdef^^cf{\"I}
+ %
+ \gdef^^d0{\missingcharmsg{LATIN CAPITAL LETTER ETH}}
+ \gdef^^d1{\~N}
+ \gdef^^d2{\`O}
+ \gdef^^d3{\'O}
+ \gdef^^d4{\^O}
+ \gdef^^d5{\~O}
+ \gdef^^d6{\"O}
+ \gdef^^d7{$\times$}
+ \gdef^^d8{\O}
+ \gdef^^d9{\`U}
+ \gdef^^da{\'U}
+ \gdef^^db{\^U}
+ \gdef^^dc{\"U}
+ \gdef^^dd{\'Y}
+ \gdef^^de{\missingcharmsg{LATIN CAPITAL LETTER THORN}}
+ \gdef^^df{\ss}
+ %
+ \gdef^^e0{\`a}
+ \gdef^^e1{\'a}
+ \gdef^^e2{\^a}
+ \gdef^^e3{\~a}
+ \gdef^^e4{\"a}
+ \gdef^^e5{\ringaccent a}
+ \gdef^^e6{\ae}
+ \gdef^^e7{\cedilla c}
+ \gdef^^e8{\`e}
+ \gdef^^e9{\'e}
+ \gdef^^ea{\^e}
+ \gdef^^eb{\"e}
+ \gdef^^ec{\`{\dotless i}}
+ \gdef^^ed{\'{\dotless i}}
+ \gdef^^ee{\^{\dotless i}}
+ \gdef^^ef{\"{\dotless i}}
+ %
+ \gdef^^f0{\missingcharmsg{LATIN SMALL LETTER ETH}}
+ \gdef^^f1{\~n}
+ \gdef^^f2{\`o}
+ \gdef^^f3{\'o}
+ \gdef^^f4{\^o}
+ \gdef^^f5{\~o}
+ \gdef^^f6{\"o}
+ \gdef^^f7{$\div$}
+ \gdef^^f8{\o}
+ \gdef^^f9{\`u}
+ \gdef^^fa{\'u}
+ \gdef^^fb{\^u}
+ \gdef^^fc{\"u}
+ \gdef^^fd{\'y}
+ \gdef^^fe{\missingcharmsg{LATIN SMALL LETTER THORN}}
+ \gdef^^ff{\"y}
+}
+
+% Latin9 (ISO-8859-15) encoding character definitions.
+\def\latninechardefs{%
+ % Encoding is almost identical to Latin1.
+ \latonechardefs
+ %
+ \gdef^^a4{\euro}
+ \gdef^^a6{\v S}
+ \gdef^^a8{\v s}
+ \gdef^^b4{\v Z}
+ \gdef^^b8{\v z}
+ \gdef^^bc{\OE}
+ \gdef^^bd{\oe}
+ \gdef^^be{\"Y}
+}
+
+% Latin2 (ISO-8859-2) character definitions.
+\def\lattwochardefs{%
+ \gdef^^a0{~}
+ \gdef^^a1{\missingcharmsg{LATIN CAPITAL LETTER A WITH OGONEK}}
+ \gdef^^a2{\u{}}
+ \gdef^^a3{\L}
+ \gdef^^a4{\missingcharmsg{CURRENCY SIGN}}
+ \gdef^^a5{\v L}
+ \gdef^^a6{\'S}
+ \gdef^^a7{\S}
+ \gdef^^a8{\"{}}
+ \gdef^^a9{\v S}
+ \gdef^^aa{\cedilla S}
+ \gdef^^ab{\v T}
+ \gdef^^ac{\'Z}
+ \gdef^^ad{\-}
+ \gdef^^ae{\v Z}
+ \gdef^^af{\dotaccent Z}
+ %
+ \gdef^^b0{\textdegree}
+ \gdef^^b1{\missingcharmsg{LATIN SMALL LETTER A WITH OGONEK}}
+ \gdef^^b2{\missingcharmsg{OGONEK}}
+ \gdef^^b3{\l}
+ \gdef^^b4{\'{}}
+ \gdef^^b5{\v l}
+ \gdef^^b6{\'s}
+ \gdef^^b7{\v{}}
+ \gdef^^b8{\cedilla\ }
+ \gdef^^b9{\v s}
+ \gdef^^ba{\cedilla s}
+ \gdef^^bb{\v t}
+ \gdef^^bc{\'z}
+ \gdef^^bd{\H{}}
+ \gdef^^be{\v z}
+ \gdef^^bf{\dotaccent z}
+ %
+ \gdef^^c0{\'R}
+ \gdef^^c1{\'A}
+ \gdef^^c2{\^A}
+ \gdef^^c3{\u A}
+ \gdef^^c4{\"A}
+ \gdef^^c5{\'L}
+ \gdef^^c6{\'C}
+ \gdef^^c7{\cedilla C}
+ \gdef^^c8{\v C}
+ \gdef^^c9{\'E}
+ \gdef^^ca{\missingcharmsg{LATIN CAPITAL LETTER E WITH OGONEK}}
+ \gdef^^cb{\"E}
+ \gdef^^cc{\v E}
+ \gdef^^cd{\'I}
+ \gdef^^ce{\^I}
+ \gdef^^cf{\v D}
+ %
+ \gdef^^d0{\missingcharmsg{LATIN CAPITAL LETTER D WITH STROKE}}
+ \gdef^^d1{\'N}
+ \gdef^^d2{\v N}
+ \gdef^^d3{\'O}
+ \gdef^^d4{\^O}
+ \gdef^^d5{\H O}
+ \gdef^^d6{\"O}
+ \gdef^^d7{$\times$}
+ \gdef^^d8{\v R}
+ \gdef^^d9{\ringaccent U}
+ \gdef^^da{\'U}
+ \gdef^^db{\H U}
+ \gdef^^dc{\"U}
+ \gdef^^dd{\'Y}
+ \gdef^^de{\cedilla T}
+ \gdef^^df{\ss}
+ %
+ \gdef^^e0{\'r}
+ \gdef^^e1{\'a}
+ \gdef^^e2{\^a}
+ \gdef^^e3{\u a}
+ \gdef^^e4{\"a}
+ \gdef^^e5{\'l}
+ \gdef^^e6{\'c}
+ \gdef^^e7{\cedilla c}
+ \gdef^^e8{\v c}
+ \gdef^^e9{\'e}
+ \gdef^^ea{\missingcharmsg{LATIN SMALL LETTER E WITH OGONEK}}
+ \gdef^^eb{\"e}
+ \gdef^^ec{\v e}
+ \gdef^^ed{\'\i}
+ \gdef^^ee{\^\i}
+ \gdef^^ef{\v d}
+ %
+ \gdef^^f0{\missingcharmsg{LATIN SMALL LETTER D WITH STROKE}}
+ \gdef^^f1{\'n}
+ \gdef^^f2{\v n}
+ \gdef^^f3{\'o}
+ \gdef^^f4{\^o}
+ \gdef^^f5{\H o}
+ \gdef^^f6{\"o}
+ \gdef^^f7{$\div$}
+ \gdef^^f8{\v r}
+ \gdef^^f9{\ringaccent u}
+ \gdef^^fa{\'u}
+ \gdef^^fb{\H u}
+ \gdef^^fc{\"u}
+ \gdef^^fd{\'y}
+ \gdef^^fe{\cedilla t}
+ \gdef^^ff{\dotaccent{}}
+}
+
+% UTF-8 character definitions.
+%
+% This code to support UTF-8 is based on LaTeX's utf8.def, with some
+% changes for Texinfo conventions. It is included here under the GPL by
+% permission from Frank Mittelbach and the LaTeX team.
+%
+\newcount\countUTFx
+\newcount\countUTFy
+\newcount\countUTFz
+
+\gdef\UTFviiiTwoOctets#1#2{\expandafter
+ \UTFviiiDefined\csname u8:#1\string #2\endcsname}
+%
+\gdef\UTFviiiThreeOctets#1#2#3{\expandafter
+ \UTFviiiDefined\csname u8:#1\string #2\string #3\endcsname}
+%
+\gdef\UTFviiiFourOctets#1#2#3#4{\expandafter
+ \UTFviiiDefined\csname u8:#1\string #2\string #3\string #4\endcsname}
+
+\gdef\UTFviiiDefined#1{%
+ \ifx #1\relax
+ \message{\linenumber Unicode char \string #1 not defined for Texinfo}%
+ \else
+ \expandafter #1%
+ \fi
+}
+
+\begingroup
+ \catcode`\~13
+ \catcode`\"12
+
+ \def\UTFviiiLoop{%
+ \global\catcode\countUTFx\active
+ \uccode`\~\countUTFx
+ \uppercase\expandafter{\UTFviiiTmp}%
+ \advance\countUTFx by 1
+ \ifnum\countUTFx < \countUTFy
+ \expandafter\UTFviiiLoop
+ \fi}
+
+ \countUTFx = "C2
+ \countUTFy = "E0
+ \def\UTFviiiTmp{%
+ \xdef~{\noexpand\UTFviiiTwoOctets\string~}}
+ \UTFviiiLoop
+
+ \countUTFx = "E0
+ \countUTFy = "F0
+ \def\UTFviiiTmp{%
+ \xdef~{\noexpand\UTFviiiThreeOctets\string~}}
+ \UTFviiiLoop
+
+ \countUTFx = "F0
+ \countUTFy = "F4
+ \def\UTFviiiTmp{%
+ \xdef~{\noexpand\UTFviiiFourOctets\string~}}
+ \UTFviiiLoop
+\endgroup
+
+\begingroup
+ \catcode`\"=12
+ \catcode`\<=12
+ \catcode`\.=12
+ \catcode`\,=12
+ \catcode`\;=12
+ \catcode`\!=12
+ \catcode`\~=13
+
+ \gdef\DeclareUnicodeCharacter#1#2{%
+ \countUTFz = "#1\relax
+ \wlog{\space\space defining Unicode char U+#1 (decimal \the\countUTFz)}%
+ \begingroup
+ \parseXMLCharref
+ \def\UTFviiiTwoOctets##1##2{%
+ \csname u8:##1\string ##2\endcsname}%
+ \def\UTFviiiThreeOctets##1##2##3{%
+ \csname u8:##1\string ##2\string ##3\endcsname}%
+ \def\UTFviiiFourOctets##1##2##3##4{%
+ \csname u8:##1\string ##2\string ##3\string ##4\endcsname}%
+ \expandafter\expandafter\expandafter\expandafter
+ \expandafter\expandafter\expandafter
+ \gdef\UTFviiiTmp{#2}%
+ \endgroup}
+
+ \gdef\parseXMLCharref{%
+ \ifnum\countUTFz < "A0\relax
+ \errhelp = \EMsimple
+ \errmessage{Cannot define Unicode char value < 00A0}%
+ \else\ifnum\countUTFz < "800\relax
+ \parseUTFviiiA,%
+ \parseUTFviiiB C\UTFviiiTwoOctets.,%
+ \else\ifnum\countUTFz < "10000\relax
+ \parseUTFviiiA;%
+ \parseUTFviiiA,%
+ \parseUTFviiiB E\UTFviiiThreeOctets.{,;}%
+ \else
+ \parseUTFviiiA;%
+ \parseUTFviiiA,%
+ \parseUTFviiiA!%
+ \parseUTFviiiB F\UTFviiiFourOctets.{!,;}%
+ \fi\fi\fi
+ }
+
+ \gdef\parseUTFviiiA#1{%
+ \countUTFx = \countUTFz
+ \divide\countUTFz by 64
+ \countUTFy = \countUTFz
+ \multiply\countUTFz by 64
+ \advance\countUTFx by -\countUTFz
+ \advance\countUTFx by 128
+ \uccode `#1\countUTFx
+ \countUTFz = \countUTFy}
+
+ \gdef\parseUTFviiiB#1#2#3#4{%
+ \advance\countUTFz by "#10\relax
+ \uccode `#3\countUTFz
+ \uppercase{\gdef\UTFviiiTmp{#2#3#4}}}
+\endgroup
+
+\def\utfeightchardefs{%
+ \DeclareUnicodeCharacter{00A0}{\tie}
+ \DeclareUnicodeCharacter{00A1}{\exclamdown}
+ \DeclareUnicodeCharacter{00A3}{\pounds}
+ \DeclareUnicodeCharacter{00A8}{\"{ }}
+ \DeclareUnicodeCharacter{00A9}{\copyright}
+ \DeclareUnicodeCharacter{00AA}{\ordf}
+ \DeclareUnicodeCharacter{00AB}{\guillemetleft}
+ \DeclareUnicodeCharacter{00AD}{\-}
+ \DeclareUnicodeCharacter{00AE}{\registeredsymbol}
+ \DeclareUnicodeCharacter{00AF}{\={ }}
+
+ \DeclareUnicodeCharacter{00B0}{\ringaccent{ }}
+ \DeclareUnicodeCharacter{00B4}{\'{ }}
+ \DeclareUnicodeCharacter{00B8}{\cedilla{ }}
+ \DeclareUnicodeCharacter{00BA}{\ordm}
+ \DeclareUnicodeCharacter{00BB}{\guillemetright}
+ \DeclareUnicodeCharacter{00BF}{\questiondown}
+
+ \DeclareUnicodeCharacter{00C0}{\`A}
+ \DeclareUnicodeCharacter{00C1}{\'A}
+ \DeclareUnicodeCharacter{00C2}{\^A}
+ \DeclareUnicodeCharacter{00C3}{\~A}
+ \DeclareUnicodeCharacter{00C4}{\"A}
+ \DeclareUnicodeCharacter{00C5}{\AA}
+ \DeclareUnicodeCharacter{00C6}{\AE}
+ \DeclareUnicodeCharacter{00C7}{\cedilla{C}}
+ \DeclareUnicodeCharacter{00C8}{\`E}
+ \DeclareUnicodeCharacter{00C9}{\'E}
+ \DeclareUnicodeCharacter{00CA}{\^E}
+ \DeclareUnicodeCharacter{00CB}{\"E}
+ \DeclareUnicodeCharacter{00CC}{\`I}
+ \DeclareUnicodeCharacter{00CD}{\'I}
+ \DeclareUnicodeCharacter{00CE}{\^I}
+ \DeclareUnicodeCharacter{00CF}{\"I}
+
+ \DeclareUnicodeCharacter{00D1}{\~N}
+ \DeclareUnicodeCharacter{00D2}{\`O}
+ \DeclareUnicodeCharacter{00D3}{\'O}
+ \DeclareUnicodeCharacter{00D4}{\^O}
+ \DeclareUnicodeCharacter{00D5}{\~O}
+ \DeclareUnicodeCharacter{00D6}{\"O}
+ \DeclareUnicodeCharacter{00D8}{\O}
+ \DeclareUnicodeCharacter{00D9}{\`U}
+ \DeclareUnicodeCharacter{00DA}{\'U}
+ \DeclareUnicodeCharacter{00DB}{\^U}
+ \DeclareUnicodeCharacter{00DC}{\"U}
+ \DeclareUnicodeCharacter{00DD}{\'Y}
+ \DeclareUnicodeCharacter{00DF}{\ss}
+
+ \DeclareUnicodeCharacter{00E0}{\`a}
+ \DeclareUnicodeCharacter{00E1}{\'a}
+ \DeclareUnicodeCharacter{00E2}{\^a}
+ \DeclareUnicodeCharacter{00E3}{\~a}
+ \DeclareUnicodeCharacter{00E4}{\"a}
+ \DeclareUnicodeCharacter{00E5}{\aa}
+ \DeclareUnicodeCharacter{00E6}{\ae}
+ \DeclareUnicodeCharacter{00E7}{\cedilla{c}}
+ \DeclareUnicodeCharacter{00E8}{\`e}
+ \DeclareUnicodeCharacter{00E9}{\'e}
+ \DeclareUnicodeCharacter{00EA}{\^e}
+ \DeclareUnicodeCharacter{00EB}{\"e}
+ \DeclareUnicodeCharacter{00EC}{\`{\dotless{i}}}
+ \DeclareUnicodeCharacter{00ED}{\'{\dotless{i}}}
+ \DeclareUnicodeCharacter{00EE}{\^{\dotless{i}}}
+ \DeclareUnicodeCharacter{00EF}{\"{\dotless{i}}}
+
+ \DeclareUnicodeCharacter{00F1}{\~n}
+ \DeclareUnicodeCharacter{00F2}{\`o}
+ \DeclareUnicodeCharacter{00F3}{\'o}
+ \DeclareUnicodeCharacter{00F4}{\^o}
+ \DeclareUnicodeCharacter{00F5}{\~o}
+ \DeclareUnicodeCharacter{00F6}{\"o}
+ \DeclareUnicodeCharacter{00F8}{\o}
+ \DeclareUnicodeCharacter{00F9}{\`u}
+ \DeclareUnicodeCharacter{00FA}{\'u}
+ \DeclareUnicodeCharacter{00FB}{\^u}
+ \DeclareUnicodeCharacter{00FC}{\"u}
+ \DeclareUnicodeCharacter{00FD}{\'y}
+ \DeclareUnicodeCharacter{00FF}{\"y}
+
+ \DeclareUnicodeCharacter{0100}{\=A}
+ \DeclareUnicodeCharacter{0101}{\=a}
+ \DeclareUnicodeCharacter{0102}{\u{A}}
+ \DeclareUnicodeCharacter{0103}{\u{a}}
+ \DeclareUnicodeCharacter{0106}{\'C}
+ \DeclareUnicodeCharacter{0107}{\'c}
+ \DeclareUnicodeCharacter{0108}{\^C}
+ \DeclareUnicodeCharacter{0109}{\^c}
+ \DeclareUnicodeCharacter{010A}{\dotaccent{C}}
+ \DeclareUnicodeCharacter{010B}{\dotaccent{c}}
+ \DeclareUnicodeCharacter{010C}{\v{C}}
+ \DeclareUnicodeCharacter{010D}{\v{c}}
+ \DeclareUnicodeCharacter{010E}{\v{D}}
+
+ \DeclareUnicodeCharacter{0112}{\=E}
+ \DeclareUnicodeCharacter{0113}{\=e}
+ \DeclareUnicodeCharacter{0114}{\u{E}}
+ \DeclareUnicodeCharacter{0115}{\u{e}}
+ \DeclareUnicodeCharacter{0116}{\dotaccent{E}}
+ \DeclareUnicodeCharacter{0117}{\dotaccent{e}}
+ \DeclareUnicodeCharacter{011A}{\v{E}}
+ \DeclareUnicodeCharacter{011B}{\v{e}}
+ \DeclareUnicodeCharacter{011C}{\^G}
+ \DeclareUnicodeCharacter{011D}{\^g}
+ \DeclareUnicodeCharacter{011E}{\u{G}}
+ \DeclareUnicodeCharacter{011F}{\u{g}}
+
+ \DeclareUnicodeCharacter{0120}{\dotaccent{G}}
+ \DeclareUnicodeCharacter{0121}{\dotaccent{g}}
+ \DeclareUnicodeCharacter{0124}{\^H}
+ \DeclareUnicodeCharacter{0125}{\^h}
+ \DeclareUnicodeCharacter{0128}{\~I}
+ \DeclareUnicodeCharacter{0129}{\~{\dotless{i}}}
+ \DeclareUnicodeCharacter{012A}{\=I}
+ \DeclareUnicodeCharacter{012B}{\={\dotless{i}}}
+ \DeclareUnicodeCharacter{012C}{\u{I}}
+ \DeclareUnicodeCharacter{012D}{\u{\dotless{i}}}
+
+ \DeclareUnicodeCharacter{0130}{\dotaccent{I}}
+ \DeclareUnicodeCharacter{0131}{\dotless{i}}
+ \DeclareUnicodeCharacter{0132}{IJ}
+ \DeclareUnicodeCharacter{0133}{ij}
+ \DeclareUnicodeCharacter{0134}{\^J}
+ \DeclareUnicodeCharacter{0135}{\^{\dotless{j}}}
+ \DeclareUnicodeCharacter{0139}{\'L}
+ \DeclareUnicodeCharacter{013A}{\'l}
+
+ \DeclareUnicodeCharacter{0141}{\L}
+ \DeclareUnicodeCharacter{0142}{\l}
+ \DeclareUnicodeCharacter{0143}{\'N}
+ \DeclareUnicodeCharacter{0144}{\'n}
+ \DeclareUnicodeCharacter{0147}{\v{N}}
+ \DeclareUnicodeCharacter{0148}{\v{n}}
+ \DeclareUnicodeCharacter{014C}{\=O}
+ \DeclareUnicodeCharacter{014D}{\=o}
+ \DeclareUnicodeCharacter{014E}{\u{O}}
+ \DeclareUnicodeCharacter{014F}{\u{o}}
+
+ \DeclareUnicodeCharacter{0150}{\H{O}}
+ \DeclareUnicodeCharacter{0151}{\H{o}}
+ \DeclareUnicodeCharacter{0152}{\OE}
+ \DeclareUnicodeCharacter{0153}{\oe}
+ \DeclareUnicodeCharacter{0154}{\'R}
+ \DeclareUnicodeCharacter{0155}{\'r}
+ \DeclareUnicodeCharacter{0158}{\v{R}}
+ \DeclareUnicodeCharacter{0159}{\v{r}}
+ \DeclareUnicodeCharacter{015A}{\'S}
+ \DeclareUnicodeCharacter{015B}{\'s}
+ \DeclareUnicodeCharacter{015C}{\^S}
+ \DeclareUnicodeCharacter{015D}{\^s}
+ \DeclareUnicodeCharacter{015E}{\cedilla{S}}
+ \DeclareUnicodeCharacter{015F}{\cedilla{s}}
+
+ \DeclareUnicodeCharacter{0160}{\v{S}}
+ \DeclareUnicodeCharacter{0161}{\v{s}}
+ \DeclareUnicodeCharacter{0162}{\cedilla{t}}
+ \DeclareUnicodeCharacter{0163}{\cedilla{T}}
+ \DeclareUnicodeCharacter{0164}{\v{T}}
+
+ \DeclareUnicodeCharacter{0168}{\~U}
+ \DeclareUnicodeCharacter{0169}{\~u}
+ \DeclareUnicodeCharacter{016A}{\=U}
+ \DeclareUnicodeCharacter{016B}{\=u}
+ \DeclareUnicodeCharacter{016C}{\u{U}}
+ \DeclareUnicodeCharacter{016D}{\u{u}}
+ \DeclareUnicodeCharacter{016E}{\ringaccent{U}}
+ \DeclareUnicodeCharacter{016F}{\ringaccent{u}}
+
+ \DeclareUnicodeCharacter{0170}{\H{U}}
+ \DeclareUnicodeCharacter{0171}{\H{u}}
+ \DeclareUnicodeCharacter{0174}{\^W}
+ \DeclareUnicodeCharacter{0175}{\^w}
+ \DeclareUnicodeCharacter{0176}{\^Y}
+ \DeclareUnicodeCharacter{0177}{\^y}
+ \DeclareUnicodeCharacter{0178}{\"Y}
+ \DeclareUnicodeCharacter{0179}{\'Z}
+ \DeclareUnicodeCharacter{017A}{\'z}
+ \DeclareUnicodeCharacter{017B}{\dotaccent{Z}}
+ \DeclareUnicodeCharacter{017C}{\dotaccent{z}}
+ \DeclareUnicodeCharacter{017D}{\v{Z}}
+ \DeclareUnicodeCharacter{017E}{\v{z}}
+
+ \DeclareUnicodeCharacter{01C4}{D\v{Z}}
+ \DeclareUnicodeCharacter{01C5}{D\v{z}}
+ \DeclareUnicodeCharacter{01C6}{d\v{z}}
+ \DeclareUnicodeCharacter{01C7}{LJ}
+ \DeclareUnicodeCharacter{01C8}{Lj}
+ \DeclareUnicodeCharacter{01C9}{lj}
+ \DeclareUnicodeCharacter{01CA}{NJ}
+ \DeclareUnicodeCharacter{01CB}{Nj}
+ \DeclareUnicodeCharacter{01CC}{nj}
+ \DeclareUnicodeCharacter{01CD}{\v{A}}
+ \DeclareUnicodeCharacter{01CE}{\v{a}}
+ \DeclareUnicodeCharacter{01CF}{\v{I}}
+
+ \DeclareUnicodeCharacter{01D0}{\v{\dotless{i}}}
+ \DeclareUnicodeCharacter{01D1}{\v{O}}
+ \DeclareUnicodeCharacter{01D2}{\v{o}}
+ \DeclareUnicodeCharacter{01D3}{\v{U}}
+ \DeclareUnicodeCharacter{01D4}{\v{u}}
+
+ \DeclareUnicodeCharacter{01E2}{\={\AE}}
+ \DeclareUnicodeCharacter{01E3}{\={\ae}}
+ \DeclareUnicodeCharacter{01E6}{\v{G}}
+ \DeclareUnicodeCharacter{01E7}{\v{g}}
+ \DeclareUnicodeCharacter{01E8}{\v{K}}
+ \DeclareUnicodeCharacter{01E9}{\v{k}}
+
+ \DeclareUnicodeCharacter{01F0}{\v{\dotless{j}}}
+ \DeclareUnicodeCharacter{01F1}{DZ}
+ \DeclareUnicodeCharacter{01F2}{Dz}
+ \DeclareUnicodeCharacter{01F3}{dz}
+ \DeclareUnicodeCharacter{01F4}{\'G}
+ \DeclareUnicodeCharacter{01F5}{\'g}
+ \DeclareUnicodeCharacter{01F8}{\`N}
+ \DeclareUnicodeCharacter{01F9}{\`n}
+ \DeclareUnicodeCharacter{01FC}{\'{\AE}}
+ \DeclareUnicodeCharacter{01FD}{\'{\ae}}
+ \DeclareUnicodeCharacter{01FE}{\'{\O}}
+ \DeclareUnicodeCharacter{01FF}{\'{\o}}
+
+ \DeclareUnicodeCharacter{021E}{\v{H}}
+ \DeclareUnicodeCharacter{021F}{\v{h}}
+
+ \DeclareUnicodeCharacter{0226}{\dotaccent{A}}
+ \DeclareUnicodeCharacter{0227}{\dotaccent{a}}
+ \DeclareUnicodeCharacter{0228}{\cedilla{E}}
+ \DeclareUnicodeCharacter{0229}{\cedilla{e}}
+ \DeclareUnicodeCharacter{022E}{\dotaccent{O}}
+ \DeclareUnicodeCharacter{022F}{\dotaccent{o}}
+
+ \DeclareUnicodeCharacter{0232}{\=Y}
+ \DeclareUnicodeCharacter{0233}{\=y}
+ \DeclareUnicodeCharacter{0237}{\dotless{j}}
+
+ \DeclareUnicodeCharacter{1E02}{\dotaccent{B}}
+ \DeclareUnicodeCharacter{1E03}{\dotaccent{b}}
+ \DeclareUnicodeCharacter{1E04}{\udotaccent{B}}
+ \DeclareUnicodeCharacter{1E05}{\udotaccent{b}}
+ \DeclareUnicodeCharacter{1E06}{\ubaraccent{B}}
+ \DeclareUnicodeCharacter{1E07}{\ubaraccent{b}}
+ \DeclareUnicodeCharacter{1E0A}{\dotaccent{D}}
+ \DeclareUnicodeCharacter{1E0B}{\dotaccent{d}}
+ \DeclareUnicodeCharacter{1E0C}{\udotaccent{D}}
+ \DeclareUnicodeCharacter{1E0D}{\udotaccent{d}}
+ \DeclareUnicodeCharacter{1E0E}{\ubaraccent{D}}
+ \DeclareUnicodeCharacter{1E0F}{\ubaraccent{d}}
+
+ \DeclareUnicodeCharacter{1E1E}{\dotaccent{F}}
+ \DeclareUnicodeCharacter{1E1F}{\dotaccent{f}}
+
+ \DeclareUnicodeCharacter{1E20}{\=G}
+ \DeclareUnicodeCharacter{1E21}{\=g}
+ \DeclareUnicodeCharacter{1E22}{\dotaccent{H}}
+ \DeclareUnicodeCharacter{1E23}{\dotaccent{h}}
+ \DeclareUnicodeCharacter{1E24}{\udotaccent{H}}
+ \DeclareUnicodeCharacter{1E25}{\udotaccent{h}}
+ \DeclareUnicodeCharacter{1E26}{\"H}
+ \DeclareUnicodeCharacter{1E27}{\"h}
+
+ \DeclareUnicodeCharacter{1E30}{\'K}
+ \DeclareUnicodeCharacter{1E31}{\'k}
+ \DeclareUnicodeCharacter{1E32}{\udotaccent{K}}
+ \DeclareUnicodeCharacter{1E33}{\udotaccent{k}}
+ \DeclareUnicodeCharacter{1E34}{\ubaraccent{K}}
+ \DeclareUnicodeCharacter{1E35}{\ubaraccent{k}}
+ \DeclareUnicodeCharacter{1E36}{\udotaccent{L}}
+ \DeclareUnicodeCharacter{1E37}{\udotaccent{l}}
+ \DeclareUnicodeCharacter{1E3A}{\ubaraccent{L}}
+ \DeclareUnicodeCharacter{1E3B}{\ubaraccent{l}}
+ \DeclareUnicodeCharacter{1E3E}{\'M}
+ \DeclareUnicodeCharacter{1E3F}{\'m}
+
+ \DeclareUnicodeCharacter{1E40}{\dotaccent{M}}
+ \DeclareUnicodeCharacter{1E41}{\dotaccent{m}}
+ \DeclareUnicodeCharacter{1E42}{\udotaccent{M}}
+ \DeclareUnicodeCharacter{1E43}{\udotaccent{m}}
+ \DeclareUnicodeCharacter{1E44}{\dotaccent{N}}
+ \DeclareUnicodeCharacter{1E45}{\dotaccent{n}}
+ \DeclareUnicodeCharacter{1E46}{\udotaccent{N}}
+ \DeclareUnicodeCharacter{1E47}{\udotaccent{n}}
+ \DeclareUnicodeCharacter{1E48}{\ubaraccent{N}}
+ \DeclareUnicodeCharacter{1E49}{\ubaraccent{n}}
+
+ \DeclareUnicodeCharacter{1E54}{\'P}
+ \DeclareUnicodeCharacter{1E55}{\'p}
+ \DeclareUnicodeCharacter{1E56}{\dotaccent{P}}
+ \DeclareUnicodeCharacter{1E57}{\dotaccent{p}}
+ \DeclareUnicodeCharacter{1E58}{\dotaccent{R}}
+ \DeclareUnicodeCharacter{1E59}{\dotaccent{r}}
+ \DeclareUnicodeCharacter{1E5A}{\udotaccent{R}}
+ \DeclareUnicodeCharacter{1E5B}{\udotaccent{r}}
+ \DeclareUnicodeCharacter{1E5E}{\ubaraccent{R}}
+ \DeclareUnicodeCharacter{1E5F}{\ubaraccent{r}}
+
+ \DeclareUnicodeCharacter{1E60}{\dotaccent{S}}
+ \DeclareUnicodeCharacter{1E61}{\dotaccent{s}}
+ \DeclareUnicodeCharacter{1E62}{\udotaccent{S}}
+ \DeclareUnicodeCharacter{1E63}{\udotaccent{s}}
+ \DeclareUnicodeCharacter{1E6A}{\dotaccent{T}}
+ \DeclareUnicodeCharacter{1E6B}{\dotaccent{t}}
+ \DeclareUnicodeCharacter{1E6C}{\udotaccent{T}}
+ \DeclareUnicodeCharacter{1E6D}{\udotaccent{t}}
+ \DeclareUnicodeCharacter{1E6E}{\ubaraccent{T}}
+ \DeclareUnicodeCharacter{1E6F}{\ubaraccent{t}}
+
+ \DeclareUnicodeCharacter{1E7C}{\~V}
+ \DeclareUnicodeCharacter{1E7D}{\~v}
+ \DeclareUnicodeCharacter{1E7E}{\udotaccent{V}}
+ \DeclareUnicodeCharacter{1E7F}{\udotaccent{v}}
+
+ \DeclareUnicodeCharacter{1E80}{\`W}
+ \DeclareUnicodeCharacter{1E81}{\`w}
+ \DeclareUnicodeCharacter{1E82}{\'W}
+ \DeclareUnicodeCharacter{1E83}{\'w}
+ \DeclareUnicodeCharacter{1E84}{\"W}
+ \DeclareUnicodeCharacter{1E85}{\"w}
+ \DeclareUnicodeCharacter{1E86}{\dotaccent{W}}
+ \DeclareUnicodeCharacter{1E87}{\dotaccent{w}}
+ \DeclareUnicodeCharacter{1E88}{\udotaccent{W}}
+ \DeclareUnicodeCharacter{1E89}{\udotaccent{w}}
+ \DeclareUnicodeCharacter{1E8A}{\dotaccent{X}}
+ \DeclareUnicodeCharacter{1E8B}{\dotaccent{x}}
+ \DeclareUnicodeCharacter{1E8C}{\"X}
+ \DeclareUnicodeCharacter{1E8D}{\"x}
+ \DeclareUnicodeCharacter{1E8E}{\dotaccent{Y}}
+ \DeclareUnicodeCharacter{1E8F}{\dotaccent{y}}
+
+ \DeclareUnicodeCharacter{1E90}{\^Z}
+ \DeclareUnicodeCharacter{1E91}{\^z}
+ \DeclareUnicodeCharacter{1E92}{\udotaccent{Z}}
+ \DeclareUnicodeCharacter{1E93}{\udotaccent{z}}
+ \DeclareUnicodeCharacter{1E94}{\ubaraccent{Z}}
+ \DeclareUnicodeCharacter{1E95}{\ubaraccent{z}}
+ \DeclareUnicodeCharacter{1E96}{\ubaraccent{h}}
+ \DeclareUnicodeCharacter{1E97}{\"t}
+ \DeclareUnicodeCharacter{1E98}{\ringaccent{w}}
+ \DeclareUnicodeCharacter{1E99}{\ringaccent{y}}
+
+ \DeclareUnicodeCharacter{1EA0}{\udotaccent{A}}
+ \DeclareUnicodeCharacter{1EA1}{\udotaccent{a}}
+
+ \DeclareUnicodeCharacter{1EB8}{\udotaccent{E}}
+ \DeclareUnicodeCharacter{1EB9}{\udotaccent{e}}
+ \DeclareUnicodeCharacter{1EBC}{\~E}
+ \DeclareUnicodeCharacter{1EBD}{\~e}
+
+ \DeclareUnicodeCharacter{1ECA}{\udotaccent{I}}
+ \DeclareUnicodeCharacter{1ECB}{\udotaccent{i}}
+ \DeclareUnicodeCharacter{1ECC}{\udotaccent{O}}
+ \DeclareUnicodeCharacter{1ECD}{\udotaccent{o}}
+
+ \DeclareUnicodeCharacter{1EE4}{\udotaccent{U}}
+ \DeclareUnicodeCharacter{1EE5}{\udotaccent{u}}
+
+ \DeclareUnicodeCharacter{1EF2}{\`Y}
+ \DeclareUnicodeCharacter{1EF3}{\`y}
+ \DeclareUnicodeCharacter{1EF4}{\udotaccent{Y}}
+
+ \DeclareUnicodeCharacter{1EF8}{\~Y}
+ \DeclareUnicodeCharacter{1EF9}{\~y}
+
+ \DeclareUnicodeCharacter{2013}{--}
+ \DeclareUnicodeCharacter{2014}{---}
+ \DeclareUnicodeCharacter{2018}{\quoteleft}
+ \DeclareUnicodeCharacter{2019}{\quoteright}
+ \DeclareUnicodeCharacter{201A}{\quotesinglbase}
+ \DeclareUnicodeCharacter{201C}{\quotedblleft}
+ \DeclareUnicodeCharacter{201D}{\quotedblright}
+ \DeclareUnicodeCharacter{201E}{\quotedblbase}
+ \DeclareUnicodeCharacter{2022}{\bullet}
+ \DeclareUnicodeCharacter{2026}{\dots}
+ \DeclareUnicodeCharacter{2039}{\guilsinglleft}
+ \DeclareUnicodeCharacter{203A}{\guilsinglright}
+ \DeclareUnicodeCharacter{20AC}{\euro}
+
+ \DeclareUnicodeCharacter{2192}{\expansion}
+ \DeclareUnicodeCharacter{21D2}{\result}
+
+ \DeclareUnicodeCharacter{2212}{\minus}
+ \DeclareUnicodeCharacter{2217}{\point}
+ \DeclareUnicodeCharacter{2261}{\equiv}
+}% end of \utfeightchardefs
+
+
+% US-ASCII character definitions.
+\def\asciichardefs{% nothing need be done
+ \relax
+}
+
+% Make non-ASCII characters printable again for compatibility with
+% existing Texinfo documents that may use them, even without declaring a
+% document encoding.
+%
+\setnonasciicharscatcode \other
+
+
+\message{formatting,}
+
+\newdimen\defaultparindent \defaultparindent = 15pt
+
+\chapheadingskip = 15pt plus 4pt minus 2pt
+\secheadingskip = 12pt plus 3pt minus 2pt
+\subsecheadingskip = 9pt plus 2pt minus 2pt
+
+% Prevent underfull vbox error messages.
+\vbadness = 10000
+
+% Don't be so finicky about underfull hboxes, either.
+\hbadness = 2000
+
+% Following George Bush, get rid of widows and orphans.
+\widowpenalty=10000
+\clubpenalty=10000
+
+% Use TeX 3.0's \emergencystretch to help line breaking, but if we're
+% using an old version of TeX, don't do anything. We want the amount of
+% stretch added to depend on the line length, hence the dependence on
+% \hsize. We call this whenever the paper size is set.
+%
+\def\setemergencystretch{%
+ \ifx\emergencystretch\thisisundefined
+ % Allow us to assign to \emergencystretch anyway.
+ \def\emergencystretch{\dimen0}%
+ \else
+ \emergencystretch = .15\hsize
+ \fi
+}
+
+% Parameters in order: 1) textheight; 2) textwidth;
+% 3) voffset; 4) hoffset; 5) binding offset; 6) topskip;
+% 7) physical page height; 8) physical page width.
+%
+% We also call \setleading{\textleading}, so the caller should define
+% \textleading. The caller should also set \parskip.
+%
+\def\internalpagesizes#1#2#3#4#5#6#7#8{%
+ \voffset = #3\relax
+ \topskip = #6\relax
+ \splittopskip = \topskip
+ %
+ \vsize = #1\relax
+ \advance\vsize by \topskip
+ \outervsize = \vsize
+ \advance\outervsize by 2\topandbottommargin
+ \pageheight = \vsize
+ %
+ \hsize = #2\relax
+ \outerhsize = \hsize
+ \advance\outerhsize by 0.5in
+ \pagewidth = \hsize
+ %
+ \normaloffset = #4\relax
+ \bindingoffset = #5\relax
+ %
+ \ifpdf
+ \pdfpageheight #7\relax
+ \pdfpagewidth #8\relax
+ % if we don't reset these, they will remain at "1 true in" of
+ % whatever layout pdftex was dumped with.
+ \pdfhorigin = 1 true in
+ \pdfvorigin = 1 true in
+ \fi
+ %
+ \setleading{\textleading}
+ %
+ \parindent = \defaultparindent
+ \setemergencystretch
+}
+
+% @letterpaper (the default).
+\def\letterpaper{{\globaldefs = 1
+ \parskip = 3pt plus 2pt minus 1pt
+ \textleading = 13.2pt
+ %
+ % If page is nothing but text, make it come out even.
+ \internalpagesizes{607.2pt}{6in}% that's 46 lines
+ {\voffset}{.25in}%
+ {\bindingoffset}{36pt}%
+ {11in}{8.5in}%
+}}
+
+% Use @smallbook to reset parameters for 7x9.25 trim size.
+\def\smallbook{{\globaldefs = 1
+ \parskip = 2pt plus 1pt
+ \textleading = 12pt
+ %
+ \internalpagesizes{7.5in}{5in}%
+ {-.2in}{0in}%
+ {\bindingoffset}{16pt}%
+ {9.25in}{7in}%
+ %
+ \lispnarrowing = 0.3in
+ \tolerance = 700
+ \hfuzz = 1pt
+ \contentsrightmargin = 0pt
+ \defbodyindent = .5cm
+}}
+
+% Use @smallerbook to reset parameters for 6x9 trim size.
+% (Just testing, parameters still in flux.)
+\def\smallerbook{{\globaldefs = 1
+ \parskip = 1.5pt plus 1pt
+ \textleading = 12pt
+ %
+ \internalpagesizes{7.4in}{4.8in}%
+ {-.2in}{-.4in}%
+ {0pt}{14pt}%
+ {9in}{6in}%
+ %
+ \lispnarrowing = 0.25in
+ \tolerance = 700
+ \hfuzz = 1pt
+ \contentsrightmargin = 0pt
+ \defbodyindent = .4cm
+}}
+
+% Use @afourpaper to print on European A4 paper.
+\def\afourpaper{{\globaldefs = 1
+ \parskip = 3pt plus 2pt minus 1pt
+ \textleading = 13.2pt
+ %
+ % Double-side printing via postscript on Laserjet 4050
+ % prints double-sided nicely when \bindingoffset=10mm and \hoffset=-6mm.
+ % To change the settings for a different printer or situation, adjust
+ % \normaloffset until the front-side and back-side texts align. Then
+ % do the same for \bindingoffset. You can set these for testing in
+ % your texinfo source file like this:
+ % @tex
+ % \global\normaloffset = -6mm
+ % \global\bindingoffset = 10mm
+ % @end tex
+ \internalpagesizes{673.2pt}{160mm}% that's 51 lines
+ {\voffset}{\hoffset}%
+ {\bindingoffset}{44pt}%
+ {297mm}{210mm}%
+ %
+ \tolerance = 700
+ \hfuzz = 1pt
+ \contentsrightmargin = 0pt
+ \defbodyindent = 5mm
+}}
+
+% Use @afivepaper to print on European A5 paper.
+% From romildo@urano.iceb.ufop.br, 2 July 2000.
+% He also recommends making @example and @lisp be small.
+\def\afivepaper{{\globaldefs = 1
+ \parskip = 2pt plus 1pt minus 0.1pt
+ \textleading = 12.5pt
+ %
+ \internalpagesizes{160mm}{120mm}%
+ {\voffset}{\hoffset}%
+ {\bindingoffset}{8pt}%
+ {210mm}{148mm}%
+ %
+ \lispnarrowing = 0.2in
+ \tolerance = 800
+ \hfuzz = 1.2pt
+ \contentsrightmargin = 0pt
+ \defbodyindent = 2mm
+ \tableindent = 12mm
+}}
+
+% A specific text layout, 24x15cm overall, intended for A4 paper.
+\def\afourlatex{{\globaldefs = 1
+ \afourpaper
+ \internalpagesizes{237mm}{150mm}%
+ {\voffset}{4.6mm}%
+ {\bindingoffset}{7mm}%
+ {297mm}{210mm}%
+ %
+ % Must explicitly reset to 0 because we call \afourpaper.
+ \globaldefs = 0
+}}
+
+% Use @afourwide to print on A4 paper in landscape format.
+\def\afourwide{{\globaldefs = 1
+ \afourpaper
+ \internalpagesizes{241mm}{165mm}%
+ {\voffset}{-2.95mm}%
+ {\bindingoffset}{7mm}%
+ {297mm}{210mm}%
+ \globaldefs = 0
+}}
+
+% @pagesizes TEXTHEIGHT[,TEXTWIDTH]
+% Perhaps we should allow setting the margins, \topskip, \parskip,
+% and/or leading, also. Or perhaps we should compute them somehow.
+%
+\parseargdef\pagesizes{\pagesizesyyy #1,,\finish}
+\def\pagesizesyyy#1,#2,#3\finish{{%
+ \setbox0 = \hbox{\ignorespaces #2}\ifdim\wd0 > 0pt \hsize=#2\relax \fi
+ \globaldefs = 1
+ %
+ \parskip = 3pt plus 2pt minus 1pt
+ \setleading{\textleading}%
+ %
+ \dimen0 = #1\relax
+ \advance\dimen0 by \voffset
+ %
+ \dimen2 = \hsize
+ \advance\dimen2 by \normaloffset
+ %
+ \internalpagesizes{#1}{\hsize}%
+ {\voffset}{\normaloffset}%
+ {\bindingoffset}{44pt}%
+ {\dimen0}{\dimen2}%
+}}
+
+% Set default to letter.
+%
+\letterpaper
+
+
+\message{and turning on texinfo input format.}
+
+% Define macros to output various characters with catcode for normal text.
+\catcode`\"=\other
+\catcode`\~=\other
+\catcode`\^=\other
+\catcode`\_=\other
+\catcode`\|=\other
+\catcode`\<=\other
+\catcode`\>=\other
+\catcode`\+=\other
+\catcode`\$=\other
+\def\normaldoublequote{"}
+\def\normaltilde{~}
+\def\normalcaret{^}
+\def\normalunderscore{_}
+\def\normalverticalbar{|}
+\def\normalless{<}
+\def\normalgreater{>}
+\def\normalplus{+}
+\def\normaldollar{$}%$ font-lock fix
+
+% This macro is used to make a character print one way in \tt
+% (where it can probably be output as-is), and another way in other fonts,
+% where something hairier probably needs to be done.
+%
+% #1 is what to print if we are indeed using \tt; #2 is what to print
+% otherwise. Since all the Computer Modern typewriter fonts have zero
+% interword stretch (and shrink), and it is reasonable to expect all
+% typewriter fonts to have this, we can check that font parameter.
+%
+\def\ifusingtt#1#2{\ifdim \fontdimen3\font=0pt #1\else #2\fi}
+
+% Same as above, but check for italic font. Actually this also catches
+% non-italic slanted fonts since it is impossible to distinguish them from
+% italic fonts. But since this is only used by $ and it uses \sl anyway
+% this is not a problem.
+\def\ifusingit#1#2{\ifdim \fontdimen1\font>0pt #1\else #2\fi}
+
+% Turn off all special characters except @
+% (and those which the user can use as if they were ordinary).
+% Most of these we simply print from the \tt font, but for some, we can
+% use math or other variants that look better in normal text.
+
+\catcode`\"=\active
+\def\activedoublequote{{\tt\char34}}
+\let"=\activedoublequote
+\catcode`\~=\active
+\def~{{\tt\char126}}
+\chardef\hat=`\^
+\catcode`\^=\active
+\def^{{\tt \hat}}
+
+\catcode`\_=\active
+\def_{\ifusingtt\normalunderscore\_}
+\let\realunder=_
+% Subroutine for the previous macro.
+\def\_{\leavevmode \kern.07em \vbox{\hrule width.3em height.1ex}\kern .07em }
+
+\catcode`\|=\active
+\def|{{\tt\char124}}
+\chardef \less=`\<
+\catcode`\<=\active
+\def<{{\tt \less}}
+\chardef \gtr=`\>
+\catcode`\>=\active
+\def>{{\tt \gtr}}
+\catcode`\+=\active
+\def+{{\tt \char 43}}
+\catcode`\$=\active
+\def${\ifusingit{{\sl\$}}\normaldollar}%$ font-lock fix
+
+% If a .fmt file is being used, characters that might appear in a file
+% name cannot be active until we have parsed the command line.
+% So turn them off again, and have \everyjob (or @setfilename) turn them on.
+% \otherifyactive is called near the end of this file.
+\def\otherifyactive{\catcode`+=\other \catcode`\_=\other}
+
+% Used sometimes to turn off (effectively) the active characters even after
+% parsing them.
+\def\turnoffactive{%
+ \normalturnoffactive
+ \otherbackslash
+}
+
+\catcode`\@=0
+
+% \backslashcurfont outputs one backslash character in current font,
+% as in \char`\\.
+\global\chardef\backslashcurfont=`\\
+\global\let\rawbackslashxx=\backslashcurfont % let existing .??s files work
+
+% \realbackslash is an actual character `\' with catcode other, and
+% \doublebackslash is two of them (for the pdf outlines).
+{\catcode`\\=\other @gdef@realbackslash{\} @gdef@doublebackslash{\\}}
+
+% In texinfo, backslash is an active character; it prints the backslash
+% in fixed width font.
+\catcode`\\=\active
+@def@normalbackslash{{@tt@backslashcurfont}}
+% On startup, @fixbackslash assigns:
+% @let \ = @normalbackslash
+
+% \rawbackslash defines an active \ to do \backslashcurfont.
+% \otherbackslash defines an active \ to be a literal `\' character with
+% catcode other.
+@gdef@rawbackslash{@let\=@backslashcurfont}
+@gdef@otherbackslash{@let\=@realbackslash}
+
+% Same as @turnoffactive except outputs \ as {\tt\char`\\} instead of
+% the literal character `\'.
+%
+@def@normalturnoffactive{%
+ @let\=@normalbackslash
+ @let"=@normaldoublequote
+ @let~=@normaltilde
+ @let^=@normalcaret
+ @let_=@normalunderscore
+ @let|=@normalverticalbar
+ @let<=@normalless
+ @let>=@normalgreater
+ @let+=@normalplus
+ @let$=@normaldollar %$ font-lock fix
+ @unsepspaces
+}
+
+% Make _ and + \other characters, temporarily.
+% This is canceled by @fixbackslash.
+@otherifyactive
+
+% If a .fmt file is being used, we don't want the `\input texinfo' to show up.
+% That is what \eatinput is for; after that, the `\' should revert to printing
+% a backslash.
+%
+@gdef@eatinput input texinfo{@fixbackslash}
+@global@let\ = @eatinput
+
+% On the other hand, perhaps the file did not have a `\input texinfo'. Then
+% the first `\' in the file would cause an error. This macro tries to fix
+% that, assuming it is called before the first `\' could plausibly occur.
+% Also turn back on active characters that might appear in the input
+% file name, in case not using a pre-dumped format.
+%
+@gdef@fixbackslash{%
+ @ifx\@eatinput @let\ = @normalbackslash @fi
+ @catcode`+=@active
+ @catcode`@_=@active
+}
+
+% Say @foo, not \foo, in error messages.
+@escapechar = `@@
+
+% These look ok in all fonts, so just make them not special.
+@catcode`@& = @other
+@catcode`@# = @other
+@catcode`@% = @other
+
+
+@c Local variables:
+@c eval: (add-hook 'write-file-hooks 'time-stamp)
+@c page-delimiter: "^\\\\message"
+@c time-stamp-start: "def\\\\texinfoversion{"
+@c time-stamp-format: "%:y-%02m-%02d.%02H"
+@c time-stamp-end: "}"
+@c End:
+
+@c vim:sw=2:
+
+@ignore
+ arch-tag: e1b36e32-c96e-4135-a41a-0b2efa2ea115
+@end ignore
--- /dev/null
+#!/bin/bash
+thisdir=$(cd $(dirname $0) && pwd)
+export GUILE_LOAD_PATH=$thisdir/module${GUILE_LOAD_PATH:+:$GUILE_LOAD_PATH}
+export LD_LIBRARY_PATH=$thisdir/src${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}
+exec "$@"
(set-buffered-input-continuation?! (readline-port) #f)
(set-readline-prompt! repl-prompt "... ")
(set-readline-read-hook! repl-read-hook))
- (lambda () (read))
+ (lambda () ((or (fluid-ref current-reader) read)))
(lambda ()
(set-readline-prompt! outer-new-input-prompt outer-continuation-prompt)
(set-readline-read-hook! outer-read-hook))))))
--- /dev/null
+GOBJECTS = $(SOURCES:%.scm=%.go)
+
+moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
+mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) $(GOBJECTS)
+EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
+
+CLEANFILES = $(GOBJECTS)
+
+SUFFIXES = .scm .go
+.scm.go:
+ $(top_builddir)/pre-inst-guile -s \$(top_builddir)/src/guilec $<
SUBDIRS = debugger debugging
# These should be installed and distributed.
-ice9_sources = \
- and-let-star.scm boot-9.scm calling.scm common-list.scm \
+modpath = ice-9
+SOURCES = and-let-star.scm
+NOCOMP_SOURCES = \
+ boot-9.scm calling.scm common-list.scm \
debug.scm debugger.scm documentation.scm emacs.scm expect.scm \
format.scm getopt-long.scm hcons.scm i18n.scm \
lineio.scm ls.scm mapping.scm \
weak-vector.scm deprecated.scm list.scm serialize.scm \
gds-client.scm gds-server.scm
-subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9
-subpkgdata_DATA = $(ice9_sources)
-TAGS_FILES = $(subpkgdata_DATA)
+include $(top_srcdir)/guilec.mk
## test.scm is not currently installed.
-EXTRA_DIST = $(ice9_sources) test.scm compile-psyntax.scm
+EXTRA_DIST += test.scm compile-psyntax.scm
+
+TAGS_FILES = $(SOURCES)
if MAINTAINER_MODE
# We expect this to never be invoked when there is not already
;; (eval-case ((situation*) forms)* (else forms)?)
;;
;; Evaluate certain code based on the situation that eval-case is used
-;; in. The only defined situation right now is `load-toplevel' which
-;; triggers for code evaluated at the top-level, for example from the
-;; REPL or when loading a file.
+;; in. There are three situations defined. `load-toplevel' triggers for
+;; code evaluated at the top-level, for example from the REPL or when
+;; loading a file. `compile-toplevel' triggers for code compiled at the
+;; toplevel. `execute' triggers during execution of code not at the top
+;; level.
(define eval-case
(procedure->memoizing-macro
(lambda (name parms . body)
(let ((transformer `(lambda ,parms ,@body)))
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(define ,name (defmacro:transformer ,transformer)))
(else
(error "defmacro can only be used at the top level")))))))
#f)))))
(define (has-suffix? str suffix)
- (let ((sufl (string-length suffix))
- (sl (string-length str)))
- (and (> sl sufl)
- (string=? (substring str (- sl sufl) sl) suffix))))
+ (string-suffix? suffix str))
(define (system-error-errno args)
(if (eq? (car args) 'system-error)
;;; {Compiled module}
-(define load-compiled #f)
+(if (not (defined? 'load-compiled))
+ (define load-compiled #f))
\f
(lambda () (autoload-in-progress! dir-hint name))
(lambda ()
(let ((file (in-vicinity dir-hint name)))
- (cond ((and load-compiled
- (%search-load-path (string-append file ".go")))
- => (lambda (full)
- (load-file load-compiled full)))
- ((%search-load-path file)
- => (lambda (full)
- (with-fluids ((current-reader #f))
- (load-file primitive-load full)))))))
+ (let ((compiled (and load-compiled
+ (%search-load-path
+ (string-append file ".go"))))
+ (source (%search-load-path file)))
+ (cond ((and source
+ (or (not compiled)
+ (< (stat:mtime (stat compiled))
+ (stat:mtime (stat source)))))
+ (if compiled
+ (warn "source file" source "newer than" compiled))
+ (with-fluids ((current-reader #f))
+ (load-file primitive-load source)))
+ (compiled
+ (load-file load-compiled compiled))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
(define ,(caddr options/enable/disable)
,(make-disable interface))
(defmacro ,(caaddr option-group) (opt val)
- `(,,(car options/enable/disable)
- (append (,,(car options/enable/disable))
+ `(,',(car options/enable/disable)
+ (append (,',(car options/enable/disable))
(list ',opt ,val))))))))))
(define-option-interface
;;; the readline library.
(define repl-reader
(lambda (prompt)
- (display prompt)
+ (display (if (string? prompt) prompt (prompt)))
(force-output)
(run-hook before-read-hook)
((or (fluid-ref current-reader) read) (current-input-port))))
(car rest)
`(lambda ,(cdr first) ,@rest))))
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(define ,name (defmacro:transformer ,transformer)))
(else
(error "define-macro can only be used at the top level")))))
(car rest)
`(lambda ,(cdr first) ,@rest))))
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(define ,name (defmacro:syntax-transformer ,transformer)))
(else
(error "define-syntax-macro can only be used at the top level")))))
(defmacro define-module args
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(let ((m (process-define-module
(list ,@(compile-define-module-args args)))))
(set-current-module m)
(defmacro use-modules modules
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(process-use-modules
(list ,@(map (lambda (m)
`(list ,@(compile-interface-spec m)))
(defmacro use-syntax (spec)
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
,@(if (pair? spec)
`((process-use-modules (list
(list ,@(compile-interface-spec spec))))
(let ((name (defined-name (car args))))
`(begin
(define-private ,@args)
- (eval-case ((load-toplevel) (export ,name))))))))
+ (eval-case ((load-toplevel compile-toplevel) (export ,name))))))))
(defmacro defmacro-public args
(define (syntax)
(#t
(let ((name (defined-name (car args))))
`(begin
- (eval-case ((load-toplevel) (export-syntax ,name)))
+ (eval-case ((load-toplevel compile-toplevel) (export-syntax ,name)))
(defmacro ,@args))))))
;; Export a local variable
(defmacro export names
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(call-with-deferred-observers
(lambda ()
(module-export! (current-module) ',names))))
(defmacro re-export names
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(call-with-deferred-observers
(lambda ()
(module-re-export! (current-module) ',names))))
\f
(define expansion-eval-closure (make-fluid))
+(define (current-eval-closure)
+ (or (fluid-ref expansion-eval-closure)
+ (module-eval-closure (current-module))))
(define (env->eval-closure env)
- (or (and env
- (car (last-pair env)))
- (module-eval-closure the-root-module)))
+ (and env (car (last-pair env))))
(define sc-macro
(procedure->memoizing-macro
(fluid-set! expansion-eval-closure the-syncase-eval-closure)
(define (putprop symbol key binding)
- (let* ((eval-closure (fluid-ref expansion-eval-closure))
+ (let* ((eval-closure (current-eval-closure))
;; Why not simply do (eval-closure symbol #t)?
;; Answer: That would overwrite imported bindings
(v (or (eval-closure symbol #f) ;lookup
(set-object-property! v key binding)))
(define (getprop symbol key)
- (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
+ (let* ((v ((current-eval-closure) symbol #f)))
(and v
(or (object-property v key)
(and (variable-bound? v)
(if (symbol? e)
;; pass the expression through
e
- (let* ((eval-closure (fluid-ref expansion-eval-closure))
+ (let* ((eval-closure (current-eval-closure))
(m (variable-ref (eval-closure (car e) #f))))
(if (eq? (macro-type m) 'syntax)
;; pass the expression through
;(eval-case ((load-toplevel) (export-syntax name)))
(define-syntax name rules ...)))))
-(fluid-set! expansion-eval-closure (env->eval-closure #f))
+(fluid-set! expansion-eval-closure #f)
if [ "$(cross_compiling)" = "yes" ]; then \
$(CC_FOR_BUILD) $(DEFS) $(AM_CPPFLAGS) -c -o $@ $<; \
else \
- $(COMPILE) -c -o $@ $<; \
+ $(filter-out -Werror,$(COMPILE)) -c -o $@ $<; \
fi
## Override default rule; this should run on BUILD host.
throw.c values.c variable.c vectors.c version.c vports.c weaks.c \
ramap.c unif.c
+# vm-related sources
+libguile_la_SOURCES += frames.c instructions.c objcodes.c programs.c vm.c
+
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
$(libguile_la_CFLAGS)
strports.x struct.x symbols.x threads.x throw.x values.x \
variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x
+# vm-related snarfs
+DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
+
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
+DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
+
+.c.i:
+ grep '^VM_DEFINE' $< > $@
+
BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
version.h scmconfig.h \
- $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
+ $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
EXTRA_libguile_la_SOURCES = _scm.h \
inet_aton.c memmove.c putenv.c strerror.c \
win32-uname.h win32-dirent.h win32-socket.h \
private-gc.h private-options.h
+# vm instructions
+noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
+
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
pthread-threads.h null-threads.h throw.h unif.h values.h \
variable.h vectors.h vports.h weaks.h
+modinclude_HEADERS += vm-bootstrap.h frames.h instructions.h objcodes.h \
+ programs.h vm.h vm-engine.h vm-expand.h
+
nodist_modinclude_HEADERS = version.h scmconfig.h
bin_SCRIPTS = guile-snarf
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "frames.h"
+
+\f
+scm_t_bits scm_tc16_heap_frame;
+
+SCM
+scm_c_make_heap_frame (SCM *fp)
+{
+ SCM frame;
+ SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
+ SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
+ size_t size = sizeof (SCM) * (upper - lower + 1);
+ SCM *p = scm_gc_malloc (size, "frame");
+
+ SCM_NEWSMOB (frame, scm_tc16_heap_frame, p);
+ p[0] = frame; /* self link */
+ memcpy (p + 1, lower, size - sizeof (SCM));
+
+ return frame;
+}
+
+static SCM
+heap_frame_mark (SCM obj)
+{
+ SCM *sp;
+ SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
+ SCM *limit = &SCM_FRAME_HEAP_LINK (fp);
+
+ for (sp = SCM_FRAME_LOWER_ADDRESS (fp); sp <= limit; sp++)
+ if (SCM_NIMP (*sp))
+ scm_gc_mark (*sp);
+
+ return SCM_BOOL_F;
+}
+
+static scm_sizet
+heap_frame_free (SCM obj)
+{
+ SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
+ SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
+ SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
+ size_t size = sizeof (SCM) * (upper - lower + 1);
+
+ scm_gc_free (SCM_HEAP_FRAME_DATA (obj), size, "frame");
+
+ return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_heap_frame_p, "heap-frame?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_heap_frame_p
+{
+ return SCM_BOOL (SCM_HEAP_FRAME_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_program
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ return SCM_FRAME_PROGRAM (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
+ (SCM frame, SCM index),
+ "")
+#define FUNC_NAME s_scm_frame_local_ref
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
+ return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
+ SCM_I_INUM (index));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
+ (SCM frame, SCM index, SCM val),
+ "")
+#define FUNC_NAME s_scm_frame_local_set_x
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
+ SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
+ SCM_I_INUM (index)) = val;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_return_address
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_FRAME_RETURN_ADDRESS
+ (SCM_HEAP_FRAME_POINTER (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_dynamic_link
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ return SCM_FRAME_HEAP_LINK (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_external_link
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ return SCM_FRAME_EXTERNAL_LINK (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+\f
+void
+scm_bootstrap_frames (void)
+{
+ scm_tc16_heap_frame = scm_make_smob_type ("frame", 0);
+ scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
+ scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free);
+}
+
+void
+scm_init_frames (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "frames.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_FRAMES_H_
+#define _SCM_FRAMES_H_
+
+#include <libguile.h>
+#include "programs.h"
+
+\f
+/*
+ * VM frames
+ */
+
+/* VM Frame Layout
+ ---------------
+
+ | | <- fp + bp->nargs + bp->nlocs + 4
+ +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
+ | Return address |
+ | Dynamic link |
+ | Heap link |
+ | External link | <- fp + bp->nargs + bp->nlocs
+ | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
+ | Local variable 0 | <- fp + bp->nargs
+ | Argument 1 |
+ | Argument 0 | <- fp
+ | Program | <- fp - 1
+ +------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+ | |
+
+ As can be inferred from this drawing, it is assumed that
+ `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
+ assumed to be as long as SCM objects. */
+
+#define SCM_FRAME_DATA_ADDRESS(fp) \
+ (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4)
+#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
+
+#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
+#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
+
+#define SCM_FRAME_RETURN_ADDRESS(fp) \
+ (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
+#define SCM_FRAME_DYNAMIC_LINK(fp) \
+ (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
+ ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(dl);
+#define SCM_FRAME_HEAP_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[1])
+#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0])
+#define SCM_FRAME_VARIABLE(fp,i) fp[i]
+#define SCM_FRAME_PROGRAM(fp) fp[-1]
+
+\f
+/*
+ * Heap frames
+ */
+
+extern scm_t_bits scm_tc16_heap_frame;
+
+#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
+#define SCM_HEAP_FRAME_DATA(f) ((SCM *) SCM_SMOB_DATA (f))
+#define SCM_HEAP_FRAME_SELF(f) (SCM_HEAP_FRAME_DATA (f) + 0)
+#define SCM_HEAP_FRAME_POINTER(f) (SCM_HEAP_FRAME_DATA (f) + 2)
+#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
+
+extern SCM scm_heap_frame_p (SCM obj);
+extern SCM scm_frame_program (SCM frame);
+extern SCM scm_frame_local_ref (SCM frame, SCM index);
+extern SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
+extern SCM scm_frame_return_address (SCM frame);
+extern SCM scm_frame_dynamic_link (SCM frame);
+extern SCM scm_frame_external_link (SCM frame);
+
+extern SCM scm_c_make_heap_frame (SCM *fp);
+extern void scm_bootstrap_frames (void);
+extern void scm_init_frames (void);
+
+#endif /* _SCM_FRAMES_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
#include "libguile/variable.h"
#include "libguile/vectors.h"
#include "libguile/version.h"
+#include "libguile/vm-bootstrap.h"
#include "libguile/vports.h"
#include "libguile/weaks.h"
#include "libguile/guardians.h"
scm_init_rw ();
scm_init_extensions ();
+ scm_bootstrap_vm ();
+
atexit (cleanup_for_exit);
scm_load_startup_files ();
}
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "instructions.h"
+
+struct scm_instruction scm_instruction_table[] = {
+#define VM_INSTRUCTION_TO_TABLE 1
+#include "vm-expand.h"
+#include "vm-i-system.i"
+#include "vm-i-scheme.i"
+#include "vm-i-loader.i"
+#undef VM_INSTRUCTION_TO_TABLE
+ {scm_op_last}
+};
+
+/* C interface */
+
+struct scm_instruction *
+scm_lookup_instruction (SCM name)
+{
+ struct scm_instruction *ip;
+ char *symbol;
+
+ if (SCM_SYMBOLP (name))
+ for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+ {
+ symbol = scm_to_locale_string (scm_symbol_to_string (name));
+ if ((symbol) && (strcmp (ip->name, symbol) == 0))
+ {
+ free (symbol);
+ return ip;
+ }
+
+ if (symbol)
+ free (symbol);
+ }
+
+ return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_instruction_list
+{
+ SCM list = SCM_EOL;
+ struct scm_instruction *ip;
+ for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+ list = scm_cons (scm_from_locale_symbol (ip->name), list);
+ return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_instruction_p
+{
+ return SCM_BOOL (SCM_INSTRUCTION_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_length
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_I_MAKINUM (SCM_INSTRUCTION_LENGTH (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_pops
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_I_MAKINUM (SCM_INSTRUCTION_POPS (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_pushes
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_I_MAKINUM (SCM_INSTRUCTION_PUSHES (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_to_opcode
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_I_MAKINUM (SCM_INSTRUCTION_OPCODE (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
+ (SCM op),
+ "")
+#define FUNC_NAME s_scm_opcode_to_instruction
+{
+ int i;
+ SCM_MAKE_VALIDATE (1, op, I_INUMP);
+ i = SCM_I_INUM (op);
+ SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
+ return scm_from_locale_symbol (scm_instruction_table[i].name);
+}
+#undef FUNC_NAME
+
+void
+scm_bootstrap_instructions (void)
+{
+}
+
+void
+scm_init_instructions (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "instructions.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_INSTRUCTIONS_H_
+#define _SCM_INSTRUCTIONS_H_
+
+#include <libguile.h>
+
+enum scm_opcode {
+#define VM_INSTRUCTION_TO_OPCODE 1
+#include "vm-expand.h"
+#include "vm-i-system.i"
+#include "vm-i-scheme.i"
+#include "vm-i-loader.i"
+#undef VM_INSTRUCTION_TO_OPCODE
+ scm_op_last
+};
+
+struct scm_instruction {
+ enum scm_opcode opcode; /* opcode */
+ const char *name; /* instruction name */
+ signed char len; /* Instruction length. This may be -1 for
+ the loader (see the `VM_LOADER'
+ macro). */
+ signed char npop; /* The number of values popped. This may be
+ -1 for insns like `call' which can take
+ any number of arguments. */
+ char npush; /* the number of values pushed */
+};
+
+#define SCM_INSTRUCTION_P(x) (scm_lookup_instruction (x))
+#define SCM_INSTRUCTION_OPCODE(i) (scm_lookup_instruction (i)->opcode)
+#define SCM_INSTRUCTION_NAME(i) (scm_lookup_instruction (i)->name)
+#define SCM_INSTRUCTION_LENGTH(i) (scm_lookup_instruction (i)->len)
+#define SCM_INSTRUCTION_POPS(i) (scm_lookup_instruction (i)->npop)
+#define SCM_INSTRUCTION_PUSHES(i) (scm_lookup_instruction (i)->npush)
+#define SCM_VALIDATE_INSTRUCTION(p,x) SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P)
+
+#define SCM_INSTRUCTION(i) (&scm_instruction_table[i])
+
+extern struct scm_instruction scm_instruction_table[];
+extern struct scm_instruction *scm_lookup_instruction (SCM name);
+
+extern SCM scm_instruction_list (void);
+extern SCM scm_instruction_p (SCM obj);
+extern SCM scm_instruction_length (SCM inst);
+extern SCM scm_instruction_pops (SCM inst);
+extern SCM scm_instruction_pushes (SCM inst);
+extern SCM scm_instruction_to_opcode (SCM inst);
+extern SCM scm_opcode_to_instruction (SCM op);
+
+extern void scm_bootstrap_instructions (void);
+extern void scm_init_instructions (void);
+
+#endif /* _SCM_INSTRUCTIONS_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <assert.h>
+
+#include "vm-bootstrap.h"
+#include "programs.h"
+#include "objcodes.h"
+
+#define OBJCODE_COOKIE "GOOF-0.5"
+
+\f
+/*
+ * Objcode type
+ */
+
+scm_t_bits scm_tc16_objcode;
+
+static SCM
+make_objcode (size_t size)
+#define FUNC_NAME "make_objcode"
+{
+ struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode),
+ "objcode");
+ p->size = size;
+ p->base = scm_gc_malloc (size, "objcode-base");
+ p->fd = -1;
+ SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+}
+#undef FUNC_NAME
+
+static SCM
+make_objcode_by_mmap (int fd)
+#define FUNC_NAME "make_objcode_by_mmap"
+{
+ int ret;
+ char *addr;
+ struct stat st;
+ struct scm_objcode *p;
+
+ ret = fstat (fd, &st);
+ if (ret < 0)
+ SCM_SYSERROR;
+
+ if (st.st_size <= strlen (OBJCODE_COOKIE))
+ scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
+ SCM_LIST1 (SCM_I_MAKINUM (st.st_size)));
+
+ addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
+ if (addr == MAP_FAILED)
+ SCM_SYSERROR;
+
+ if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
+ SCM_SYSERROR;
+
+ p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
+ p->size = st.st_size;
+ p->base = addr;
+ p->fd = fd;
+ SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+}
+#undef FUNC_NAME
+
+static scm_sizet
+objcode_free (SCM obj)
+#define FUNC_NAME "objcode_free"
+{
+ size_t size = sizeof (struct scm_objcode);
+ struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
+
+ if (p->fd >= 0)
+ {
+ int rv;
+ rv = munmap (p->base, p->size);
+ if (rv < 0) SCM_SYSERROR;
+ rv = close (p->fd);
+ if (rv < 0) SCM_SYSERROR;
+ }
+ else
+ scm_gc_free (p->base, p->size, "objcode-base");
+
+ scm_gc_free (p, size, "objcode");
+
+ return 0;
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * Scheme interface
+ */
+
+#if 0
+SCM_DEFINE (scm_do_pair, "do-pair", 2, 0, 0,
+ (SCM car, SCM cdr),
+ "This is a stupid test to see how cells work. (Ludo)")
+{
+ static SCM room[512];
+ static SCM *where = &room[0];
+ SCM the_pair;
+ size_t incr;
+
+ if ((scm_t_bits)where & 6)
+ {
+ /* Align the cell pointer so that Guile considers it as a
+ non-immediate object (see tags.h). */
+ incr = (scm_t_bits)where & 6;
+ incr = (~incr) & 7;
+ where += incr;
+ }
+
+ printf ("do-pair: pool @ %p, pair @ %p\n", &room[0], where);
+ where[0] = car;
+ where[1] = cdr;
+
+ the_pair = PTR2SCM (where);
+ /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a
+ "mark bitmap" at the end of a supposed cell segment which doesn't
+ exist. */
+
+ return (the_pair);
+}
+#endif
+
+SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_objcode_p
+{
+ return SCM_BOOL (SCM_OBJCODE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
+ (SCM bytecode, SCM nlocs, SCM nexts),
+ "")
+#define FUNC_NAME s_scm_bytecode_to_objcode
+{
+ size_t size;
+ ssize_t increment;
+ scm_t_array_handle handle;
+ char *base;
+ const scm_t_uint8 *c_bytecode;
+ SCM objcode;
+
+ if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
+ scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
+ SCM_VALIDATE_NUMBER (2, nlocs);
+ SCM_VALIDATE_NUMBER (3, nexts);
+
+ c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+ assert (increment == 1);
+
+ /* Account for the 10 byte-long header. */
+ size += 10;
+ objcode = make_objcode (size);
+ base = SCM_OBJCODE_BASE (objcode);
+
+ memcpy (base, OBJCODE_COOKIE, 8);
+ base[8] = scm_to_uint8 (nlocs);
+ base[9] = scm_to_uint8 (nexts);
+
+ memcpy (base + 10, c_bytecode, size - 10);
+
+ scm_array_handle_release (&handle);
+
+ return objcode;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
+ (SCM file),
+ "")
+#define FUNC_NAME s_scm_load_objcode
+{
+ int fd;
+ char *c_file;
+
+ SCM_VALIDATE_STRING (1, file);
+
+ c_file = scm_to_locale_string (file);
+ fd = open (c_file, O_RDONLY);
+ free (c_file);
+ if (fd < 0) SCM_SYSERROR;
+
+ return make_objcode_by_mmap (fd);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_to_u8vector
+{
+ scm_t_uint8 *u8vector;
+ size_t size;
+
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ size = SCM_OBJCODE_SIZE (objcode);
+ /* FIXME: Is `gc_malloc' ok here? */
+ u8vector = scm_gc_malloc (size, "objcode-u8vector");
+ memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size);
+
+ return scm_take_u8vector (u8vector, size);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_to_program
+{
+ SCM prog;
+ size_t size;
+ char *base;
+ struct scm_program *p;
+
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ base = SCM_OBJCODE_BASE (objcode);
+ size = SCM_OBJCODE_SIZE (objcode);
+ prog = scm_c_make_program (base + 10, size - 10, objcode);
+ p = SCM_PROGRAM_DATA (prog);
+ p->nlocs = base[8];
+ p->nexts = base[9];
+ return prog;
+}
+#undef FUNC_NAME
+
+\f
+void
+scm_bootstrap_objcodes (void)
+{
+ scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
+ scm_set_smob_free (scm_tc16_objcode, objcode_free);
+}
+
+void
+scm_init_objcodes (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "objcodes.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_OBJCODES_H_
+#define _SCM_OBJCODES_H_
+
+#include <libguile.h>
+
+struct scm_objcode {
+ size_t size; /* objcode size */
+ char *base; /* objcode base address */
+ int fd; /* file descriptor when mmap'ed */
+};
+
+extern scm_t_bits scm_tc16_objcode;
+
+#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
+#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
+
+#define SCM_OBJCODE_SIZE(x) (SCM_OBJCODE_DATA (x)->size)
+#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
+#define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd)
+
+extern SCM scm_load_objcode (SCM file);
+extern SCM scm_objcode_to_program (SCM objcode);
+extern SCM scm_objcode_p (SCM obj);
+extern SCM scm_bytecode_to_objcode (SCM bytecode, SCM nlocs, SCM nexts);
+extern SCM scm_objcode_to_u8vector (SCM objcode);
+
+extern void scm_bootstrap_objcodes (void);
+extern void scm_init_objcodes (void);
+
+#endif /* _SCM_OBJCODES_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "instructions.h"
+#include "programs.h"
+#include "vm.h"
+
+\f
+scm_t_bits scm_tc16_program;
+
+static SCM zero_vector;
+
+SCM
+scm_c_make_program (void *addr, size_t size, SCM holder)
+#define FUNC_NAME "scm_c_make_program"
+{
+ struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program),
+ "program");
+ p->size = size;
+ p->nargs = 0;
+ p->nrest = 0;
+ p->nlocs = 0;
+ p->nexts = 0;
+ p->meta = SCM_BOOL_F;
+ p->objs = zero_vector;
+ p->external = SCM_EOL;
+ p->holder = holder;
+
+ /* If nobody holds bytecode's address, then allocate a new memory */
+ if (SCM_FALSEP (holder))
+ {
+ p->base = scm_gc_malloc (size, "program-base");
+ memcpy (p->base, addr, size);
+ }
+ else
+ p->base = addr;
+
+ SCM_RETURN_NEWSMOB (scm_tc16_program, p);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_closure (SCM program, SCM external)
+{
+ SCM prog = scm_c_make_program (0, 0, program);
+ *SCM_PROGRAM_DATA (prog) = *SCM_PROGRAM_DATA (program);
+ SCM_PROGRAM_DATA (prog)->external = external;
+ return prog;
+}
+
+static SCM
+program_mark (SCM obj)
+{
+ struct scm_program *p = SCM_PROGRAM_DATA (obj);
+ scm_gc_mark (p->meta);
+ scm_gc_mark (p->objs);
+ scm_gc_mark (p->external);
+ return p->holder;
+}
+
+static scm_sizet
+program_free (SCM obj)
+{
+ struct scm_program *p = SCM_PROGRAM_DATA (obj);
+ scm_sizet size = (sizeof (struct scm_program));
+
+ if (SCM_FALSEP (p->holder))
+ scm_gc_free (p->base, p->size, "program-base");
+
+ scm_gc_free (p, size, "program");
+
+ return 0;
+}
+
+static SCM
+program_apply (SCM program, SCM args)
+{
+ return scm_vm_apply (scm_the_vm (), program, args);
+}
+
+\f
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_program_p
+{
+ return SCM_BOOL (SCM_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_base
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_arity
+{
+ struct scm_program *p;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ p = SCM_PROGRAM_DATA (program);
+ return SCM_LIST4 (SCM_I_MAKINUM (p->nargs),
+ SCM_I_MAKINUM (p->nrest),
+ SCM_I_MAKINUM (p->nlocs),
+ SCM_I_MAKINUM (p->nexts));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_meta
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_DATA (program)->meta;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_objects
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_DATA (program)->objs;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_external
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_DATA (program)->external;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
+ (SCM program, SCM external),
+ "Modify the list of closure variables of @var{program} (for "
+ "debugging purposes).")
+#define FUNC_NAME s_scm_program_external_set_x
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ SCM_VALIDATE_LIST (2, external);
+ SCM_PROGRAM_DATA (program)->external = external;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
+ (SCM program),
+ "Return a u8vector containing @var{program}'s bytecode.")
+#define FUNC_NAME s_scm_program_bytecode
+{
+ size_t size;
+ scm_t_uint8 *c_bytecode;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ size = SCM_PROGRAM_DATA (program)->size;
+ c_bytecode = malloc (size);
+ if (!c_bytecode)
+ return SCM_BOOL_F;
+
+ memcpy (c_bytecode, SCM_PROGRAM_DATA (program)->base, size);
+
+ return scm_take_u8vector (c_bytecode, size);
+}
+#undef FUNC_NAME
+
+
+\f
+void
+scm_bootstrap_programs (void)
+{
+ zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F));
+
+ scm_tc16_program = scm_make_smob_type ("program", 0);
+ scm_set_smob_mark (scm_tc16_program, program_mark);
+ scm_set_smob_free (scm_tc16_program, program_free);
+ scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
+}
+
+void
+scm_init_programs (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "programs.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_PROGRAMS_H_
+#define _SCM_PROGRAMS_H_
+
+#include <libguile.h>
+
+/*
+ * Programs
+ */
+
+typedef unsigned char scm_byte_t;
+
+struct scm_program {
+ size_t size; /* the size of the program */
+ unsigned char nargs; /* the number of arguments */
+ unsigned char nrest; /* the number of rest argument (0 or 1) */
+ unsigned char nlocs; /* the number of local variables */
+ unsigned char nexts; /* the number of external variables */
+ scm_byte_t *base; /* program base address */
+ SCM meta; /* meta data */
+ SCM objs; /* constant objects */
+ SCM external; /* external environment */
+ SCM holder; /* the owner of bytecode */
+};
+
+extern scm_t_bits scm_tc16_program;
+
+#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
+#define SCM_PROGRAM_DATA(x) ((struct scm_program *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+
+extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
+extern SCM scm_c_make_closure (SCM program, SCM external);
+
+extern SCM scm_program_p (SCM obj);
+extern SCM scm_program_base (SCM program);
+extern SCM scm_program_arity (SCM program);
+extern SCM scm_program_meta (SCM program);
+extern SCM scm_program_objects (SCM program);
+extern SCM scm_program_external (SCM program);
+extern SCM scm_program_external_set_x (SCM program, SCM external);
+extern SCM scm_program_bytecode (SCM program);
+
+extern void scm_bootstrap_programs (void);
+extern void scm_init_programs (void);
+
+#endif /* _SCM_PROGRAMS_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_VM_BOOTSTRAP_H_
+#define _SCM_VM_BOOTSTRAP_H_
+
+extern void scm_bootstrap_vm (void);
+
+#endif /* _SCM_VM_BOOTSTRAP_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* This file is included in vm.c twice */
+
+#include "vm-engine.h"
+
+
+static SCM
+vm_run (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "vm-engine"
+{
+ /* VM registers */
+ register scm_byte_t *ip IP_REG; /* instruction pointer */
+ register SCM *sp SP_REG; /* stack pointer */
+ register SCM *fp FP_REG; /* frame pointer */
+
+ /* Cache variables */
+ struct scm_vm *vp = SCM_VM_DATA (vm); /* VM data pointer */
+ struct scm_program *bp = NULL; /* program base pointer */
+ SCM external = SCM_EOL; /* external environment */
+ SCM *objects = NULL; /* constant objects */
+ scm_t_array_handle objects_handle; /* handle of the OBJECTS array */
+ size_t object_count; /* length of OBJECTS */
+ SCM *stack_base = vp->stack_base; /* stack base address */
+ SCM *stack_limit = vp->stack_limit; /* stack limit address */
+
+ /* Internal variables */
+ int nargs = 0;
+ long start_time = scm_c_get_internal_run_time ();
+ // SCM dynwinds = SCM_EOL;
+ SCM err_msg;
+ SCM err_args;
+#if VM_USE_HOOKS
+ SCM hook_args = SCM_LIST1 (vm);
+#endif
+ struct vm_unwind_data wind_data;
+
+ /* dynwind ended in the halt instruction */
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ wind_data.vp = vp;
+ wind_data.sp = vp->sp;
+ wind_data.fp = vp->fp;
+ wind_data.this_frame = vp->this_frame;
+ scm_dynwind_unwind_handler (vm_reset_stack, &wind_data, 0);
+
+
+#ifdef HAVE_LABELS_AS_VALUES
+ /* Jump table */
+ static void *jump_table[] = {
+#define VM_INSTRUCTION_TO_LABEL 1
+#include "vm-expand.h"
+#include "vm-i-system.i"
+#include "vm-i-scheme.i"
+#include "vm-i-loader.i"
+#undef VM_INSTRUCTION_TO_LABEL
+ };
+#endif
+
+ /* Initialization */
+ {
+ SCM prog = program;
+
+ /* Boot program */
+ scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
+ bytes[1] = scm_ilength (args); /* FIXME: argument overflow */
+ program = scm_c_make_program (bytes, 3, SCM_BOOL_F);
+
+ /* Initial frame */
+ CACHE_REGISTER ();
+ CACHE_PROGRAM ();
+ PUSH (program);
+ NEW_FRAME ();
+
+ /* Initial arguments */
+ PUSH (prog);
+ for (; !SCM_NULLP (args); args = SCM_CDR (args))
+ PUSH (SCM_CAR (args));
+ }
+
+ /* Let's go! */
+ BOOT_HOOK ();
+
+#ifndef HAVE_LABELS_AS_VALUES
+ vm_start:
+ switch (*ip++) {
+#endif
+
+#include "vm-expand.h"
+#include "vm-i-system.c"
+#include "vm-i-scheme.c"
+#include "vm-i-loader.c"
+
+#ifndef HAVE_LABELS_AS_VALUES
+ }
+#endif
+
+ /* Errors */
+ {
+ vm_error_unbound:
+ err_msg = scm_from_locale_string ("VM: Unbound variable: ~A");
+ goto vm_error;
+
+ vm_error_wrong_type_arg:
+ err_msg = scm_from_locale_string ("VM: Wrong type argument");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_wrong_num_args:
+ err_msg = scm_from_locale_string ("VM: Wrong number of arguments");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_wrong_type_apply:
+ err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
+ "[IP offset: ~a]");
+ err_args = SCM_LIST2 (program,
+ SCM_I_MAKINUM (ip - bp->base));
+ goto vm_error;
+
+ vm_error_stack_overflow:
+ err_msg = scm_from_locale_string ("VM: Stack overflow");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_stack_underflow:
+ err_msg = scm_from_locale_string ("VM: Stack underflow");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+#if VM_CHECK_IP
+ vm_error_invalid_address:
+ err_msg = scm_from_locale_string ("VM: Invalid program address");
+ err_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+#if VM_CHECK_EXTERNAL
+ vm_error_external:
+ err_msg = scm_from_locale_string ("VM: Invalid external access");
+ err_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+#if VM_CHECK_OBJECT
+ vm_error_object:
+ err_msg = scm_from_locale_string ("VM: Invalid object table access");
+ err_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+ vm_error:
+ SYNC_ALL ();
+ if (objects)
+ scm_array_handle_release (&objects_handle);
+
+ scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1);
+ }
+
+ abort (); /* never reached */
+}
+#undef FUNC_NAME
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* This file is included in vm_engine.c */
+
+/*
+ * Options
+ */
+
+#define VM_USE_HOOKS 1 /* Various hooks */
+#define VM_USE_CLOCK 1 /* Bogoclock */
+#define VM_CHECK_EXTERNAL 1 /* Check external link */
+#define VM_CHECK_OBJECT 1 /* Check object table */
+
+\f
+/*
+ * Registers
+ */
+
+/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]
+
+ Some compilers underestimate the use of the local variables representing
+ the abstract machine registers, and don't put them in hardware registers,
+ which slows down the interpreter considerably.
+ For GCC, I have hand-assigned hardware registers for several architectures.
+*/
+
+#ifdef __GNUC__
+#ifdef __mips__
+#define IP_REG asm("$16")
+#define SP_REG asm("$17")
+#define FP_REG asm("$18")
+#endif
+#ifdef __sparc__
+#define IP_REG asm("%l0")
+#define SP_REG asm("%l1")
+#define FP_REG asm("%l2")
+#endif
+#ifdef __alpha__
+#ifdef __CRAY__
+#define IP_REG asm("r9")
+#define SP_REG asm("r10")
+#define FP_REG asm("r11")
+#else
+#define IP_REG asm("$9")
+#define SP_REG asm("$10")
+#define FP_REG asm("$11")
+#endif
+#endif
+#ifdef __i386__
+#define IP_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define FP_REG
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define IP_REG asm("26")
+#define SP_REG asm("27")
+#define FP_REG asm("28")
+#endif
+#ifdef __hppa__
+#define IP_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define FP_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define IP_REG asm("a5")
+#define SP_REG asm("a4")
+#define FP_REG
+#endif
+#ifdef __arm__
+#define IP_REG asm("r9")
+#define SP_REG asm("r8")
+#define FP_REG asm("r7")
+#endif
+#endif
+
+#ifndef IP_REG
+#define IP_REG
+#endif
+#ifndef SP_REG
+#define SP_REG
+#endif
+#ifndef FP_REG
+#define FP_REG
+#endif
+
+\f
+/*
+ * Cache/Sync
+ */
+
+#define CACHE_REGISTER() \
+{ \
+ ip = vp->ip; \
+ sp = vp->sp; \
+ fp = vp->fp; \
+}
+
+#define SYNC_REGISTER() \
+{ \
+ vp->ip = ip; \
+ vp->sp = sp; \
+ vp->fp = fp; \
+}
+
+#ifdef IP_PARANOIA
+#define CHECK_IP() \
+ do { if (ip < bp->base || ip - bp->base > bp->size) abort (); } while (0)
+#else
+#define CHECK_IP()
+#endif
+
+/* Get a local copy of the program's "object table" (i.e. the vector of
+ external bindings that are referenced by the program), initialized by
+ `load-program'. */
+/* XXX: We could instead use the "simple vector macros", thus not having to
+ call `scm_vector_writable_elements ()' and the likes. */
+#define CACHE_PROGRAM() \
+{ \
+ ssize_t _vincr; \
+ \
+ if (bp != SCM_PROGRAM_DATA (program)) { \
+ bp = SCM_PROGRAM_DATA (program); \
+ /* Was: objects = SCM_VELTS (bp->objs); */ \
+ \
+ if (objects) \
+ scm_array_handle_release (&objects_handle); \
+ \
+ objects = scm_vector_writable_elements (bp->objs, &objects_handle, \
+ &object_count, &_vincr); \
+ } \
+}
+
+#define SYNC_BEFORE_GC() \
+{ \
+ SYNC_REGISTER (); \
+}
+
+#define SYNC_ALL() \
+{ \
+ SYNC_REGISTER (); \
+}
+
+\f
+/*
+ * Error check
+ */
+
+#undef CHECK_EXTERNAL
+#if VM_CHECK_EXTERNAL
+#define CHECK_EXTERNAL(e) \
+ do { if (!SCM_CONSP (e)) goto vm_error_external; } while (0)
+#else
+#define CHECK_EXTERNAL(e)
+#endif
+
+/* Accesses to a program's object table. */
+#if VM_CHECK_OBJECT
+#define CHECK_OBJECT(_num) \
+ do { if ((_num) >= object_count) goto vm_error_object; } while (0)
+#else
+#define CHECK_OBJECT(_num)
+#endif
+
+\f
+/*
+ * Hooks
+ */
+
+#undef RUN_HOOK
+#if VM_USE_HOOKS
+#define RUN_HOOK(h) \
+{ \
+ if (!SCM_FALSEP (vp->hooks[h])) \
+ { \
+ SYNC_REGISTER (); \
+ vm_heapify_frames (vm); \
+ scm_c_run_hook (vp->hooks[h], hook_args); \
+ CACHE_REGISTER (); \
+ } \
+}
+#else
+#define RUN_HOOK(h)
+#endif
+
+#define BOOT_HOOK() RUN_HOOK (SCM_VM_BOOT_HOOK)
+#define HALT_HOOK() RUN_HOOK (SCM_VM_HALT_HOOK)
+#define NEXT_HOOK() RUN_HOOK (SCM_VM_NEXT_HOOK)
+#define BREAK_HOOK() RUN_HOOK (SCM_VM_BREAK_HOOK)
+#define ENTER_HOOK() RUN_HOOK (SCM_VM_ENTER_HOOK)
+#define APPLY_HOOK() RUN_HOOK (SCM_VM_APPLY_HOOK)
+#define EXIT_HOOK() RUN_HOOK (SCM_VM_EXIT_HOOK)
+#define RETURN_HOOK() RUN_HOOK (SCM_VM_RETURN_HOOK)
+
+\f
+/*
+ * Stack operation
+ */
+
+#define CHECK_OVERFLOW() \
+ if (sp > stack_limit) \
+ goto vm_error_stack_overflow
+
+#define CHECK_UNDERFLOW() \
+ if (sp < stack_base) \
+ goto vm_error_stack_underflow;
+
+#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
+#define DROP() do { sp--; CHECK_UNDERFLOW (); } while (0)
+#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); } while (0)
+#define POP(x) do { x = *sp; DROP (); } while (0)
+
+/* A fast CONS. This has to be fast since its used, for instance, by
+ POP_LIST when fetching a function's argument list. Note: `scm_cell' is an
+ inlined function in Guile 1.7. Unfortunately, it calls
+ `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the
+ heap. XXX */
+#define CONS(x,y,z) \
+{ \
+ SYNC_BEFORE_GC (); \
+ x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z)); \
+}
+
+/* Pop the N objects on top of the stack and push a list that contains
+ them. */
+#define POP_LIST(n) \
+do \
+{ \
+ int i; \
+ SCM l = SCM_EOL; \
+ sp -= n; \
+ for (i = n; i; i--) \
+ CONS (l, sp[i], l); \
+ PUSH (l); \
+} while (0)
+
+\f
+/* Below is a (slightly broken) experiment to avoid calling `scm_cell' and to
+ allocate cells on the stack. This is a significant improvement for
+ programs which call a lot of procedures, since the procedure call
+ mechanism uses POP_LIST which normally uses `scm_cons'.
+
+ What it does is that it creates a list whose cells are allocated on the
+ VM's stack instead of being allocated on the heap via `scm_cell'. This is
+ much faster. However, if the callee does something like:
+
+ (lambda (. args)
+ (set! the-args args))
+
+ then terrible things may happen since the list of arguments may be
+ overwritten later on. */
+
+
+/* Awful hack that aligns PTR so that it can be considered as a non-immediate
+ value by Guile. */
+#define ALIGN_AS_NON_IMMEDIATE(_ptr) \
+{ \
+ if ((scm_t_bits)(_ptr) & 6) \
+ { \
+ size_t _incr; \
+ \
+ _incr = (scm_t_bits)(_ptr) & 6; \
+ _incr = (~_incr) & 7; \
+ (_ptr) += _incr; \
+ } \
+}
+
+#define POP_LIST_ON_STACK(n) \
+do \
+{ \
+ int i; \
+ if (n == 0) \
+ { \
+ sp -= n; \
+ PUSH (SCM_EOL); \
+ } \
+ else \
+ { \
+ SCM *list_head, *list; \
+ \
+ list_head = sp + 1; \
+ ALIGN_AS_NON_IMMEDIATE (list_head); \
+ list = list_head; \
+ \
+ sp -= n; \
+ for (i = 1; i <= n; i++) \
+ { \
+ /* The cell's car and cdr. */ \
+ *(list) = sp[i]; \
+ *(list + 1) = PTR2SCM (list + 2); \
+ list += 2; \
+ } \
+ \
+ /* The last pair's cdr is '(). */ \
+ list--; \
+ *list = SCM_EOL; \
+ /* Push the SCM object that points */ \
+ /* to the first cell. */ \
+ PUSH (PTR2SCM (list_head)); \
+ } \
+} \
+while (0)
+
+/* end of the experiment */
+
+\f
+#define POP_LIST_MARK() \
+do { \
+ SCM o; \
+ SCM l = SCM_EOL; \
+ POP (o); \
+ while (!SCM_UNBNDP (o)) \
+ { \
+ CONS (l, o, l); \
+ POP (o); \
+ } \
+ PUSH (l); \
+} while (0)
+
+\f
+/*
+ * Instruction operation
+ */
+
+#define FETCH() (*ip++)
+#define FETCH_LENGTH(len) do { ip = vm_fetch_length (ip, &len); } while (0)
+
+#undef CLOCK
+#if VM_USE_CLOCK
+#define CLOCK(n) vp->clock += n
+#else
+#define CLOCK(n)
+#endif
+
+#undef NEXT_JUMP
+#ifdef HAVE_LABELS_AS_VALUES
+#define NEXT_JUMP() goto *jump_table[FETCH ()]
+#else
+#define NEXT_JUMP() goto vm_start
+#endif
+
+#define NEXT \
+{ \
+ CLOCK (1); \
+ NEXT_HOOK (); \
+ NEXT_JUMP (); \
+}
+
+\f
+/*
+ * Stack frame
+ */
+
+#define INIT_ARGS() \
+{ \
+ if (bp->nrest) \
+ { \
+ int n = nargs - (bp->nargs - 1); \
+ if (n < 0) \
+ goto vm_error_wrong_num_args; \
+ POP_LIST (n); \
+ } \
+ else \
+ { \
+ if (nargs != bp->nargs) \
+ goto vm_error_wrong_num_args; \
+ } \
+}
+
+/* See frames.h for the layout of stack frames */
+
+#define NEW_FRAME() \
+{ \
+ int i; \
+ SCM ra = SCM_PACK (ip); \
+ SCM dl = SCM_PACK (fp); \
+ SCM *p = sp + 1; \
+ SCM *q = p + bp->nlocs; \
+ \
+ /* New pointers */ \
+ ip = bp->base; \
+ fp = p - bp->nargs; \
+ sp = q + 3; \
+ CHECK_OVERFLOW (); \
+ \
+ /* Init local variables */ \
+ for (; p < q; p++) \
+ *p = SCM_UNDEFINED; \
+ \
+ /* Create external variables */ \
+ external = bp->external; \
+ for (i = 0; i < bp->nexts; i++) \
+ CONS (external, SCM_UNDEFINED, external); \
+ \
+ /* Set frame data */ \
+ p[3] = ra; \
+ p[2] = dl; \
+ p[1] = SCM_BOOL_F; \
+ p[0] = external; \
+ stack_base = p + 3; \
+}
+
+#define FREE_FRAME() \
+{ \
+ SCM *last_sp = sp; \
+ SCM *last_fp = fp; \
+ SCM *p = fp + bp->nargs + bp->nlocs; \
+ \
+ /* Restore pointers */ \
+ ip = SCM_FRAME_BYTE_CAST (p[3]); \
+ fp = SCM_FRAME_STACK_CAST (p[2]); \
+ \
+ if (!SCM_FALSEP (p[1])) \
+ { \
+ /* Unlink the heap stack */ \
+ vp->this_frame = p[1]; \
+ } \
+ else \
+ { \
+ /* Move stack items */ \
+ p += 4; \
+ sp = SCM_FRAME_LOWER_ADDRESS (last_fp); \
+ while (p <= last_sp) \
+ *sp++ = *p++; \
+ sp--; \
+ } \
+ stack_base = fp ? \
+ SCM_FRAME_UPPER_ADDRESS (fp) - 1 \
+ : vp->stack_base; \
+}
+
+#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
+
+\f
+/*
+ * Function support
+ */
+
+#define ARGS1(a1) SCM a1 = sp[0];
+#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--;
+#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2;
+
+#define RETURN(x) do { *sp = x; NEXT; } while (0)
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef VM_LABEL
+#define VM_LABEL(tag) l_##tag
+#define VM_OPCODE(tag) scm_op_##tag
+
+#ifdef HAVE_LABELS_AS_VALUES
+#define VM_TAG(tag) VM_LABEL(tag):
+#define VM_ADDR(tag) &&VM_LABEL(tag)
+#else /* not HAVE_LABELS_AS_VALUES */
+#define VM_TAG(tag) case VM_OPCODE(tag):
+#define VM_ADDR(tag) NULL
+#endif /* not HAVE_LABELS_AS_VALUES */
+#endif /* VM_LABEL */
+
+#undef VM_DEFINE_INSTRUCTION
+#undef VM_DEFINE_FUNCTION
+#undef VM_DEFINE_LOADER
+#ifdef VM_INSTRUCTION_TO_TABLE
+/*
+ * These will go to scm_instruction_table in vm.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) \
+ {VM_OPCODE (tag), name, len, npop, npush},
+#define VM_DEFINE_FUNCTION(tag,name,nargs) \
+ {VM_OPCODE (tag), name, 0, nargs, 1},
+#define VM_DEFINE_LOADER(tag,name) \
+ {VM_OPCODE (tag), name, -1, 0, 1},
+
+#else
+#ifdef VM_INSTRUCTION_TO_LABEL
+/*
+ * These will go to jump_table in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_ADDR (tag),
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag),
+#define VM_DEFINE_LOADER(tag,name) VM_ADDR (tag),
+
+#else
+#ifdef VM_INSTRUCTION_TO_OPCODE
+/*
+ * These will go to scm_opcode in vm.h
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_OPCODE (tag),
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag),
+#define VM_DEFINE_LOADER(tag,name) VM_OPCODE (tag),
+
+#else /* Otherwise */
+/*
+ * These are directly included in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_TAG (tag)
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag)
+#define VM_DEFINE_LOADER(tag,name) VM_TAG (tag)
+
+#endif /* VM_INSTRUCTION_TO_OPCODE */
+#endif /* VM_INSTRUCTION_TO_LABEL */
+#endif /* VM_INSTRUCTION_TO_TABLE */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* This file is included in vm_engine.c */
+
+VM_DEFINE_LOADER (load_integer, "load-integer")
+{
+ size_t len;
+
+ FETCH_LENGTH (len);
+ if (len <= 4)
+ {
+ long val = 0;
+ while (len-- > 0)
+ val = (val << 8) + FETCH ();
+ SYNC_REGISTER ();
+ PUSH (scm_from_ulong (val));
+ NEXT;
+ }
+ else
+ SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
+}
+
+VM_DEFINE_LOADER (load_number, "load-number")
+{
+ size_t len;
+
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
+ SCM_UNDEFINED /* radix = 10 */));
+ /* Was: scm_istring2number (ip, len, 10)); */
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (load_string, "load-string")
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ PUSH (scm_from_locale_stringn ((char *)ip, len));
+ /* Was: scm_makfromstr (ip, len, 0) */
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (load_symbol, "load-symbol")
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ PUSH (scm_from_locale_symboln ((char *)ip, len));
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (load_keyword, "load-keyword")
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ PUSH (scm_from_locale_keywordn ((char *)ip, len));
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (load_program, "load-program")
+{
+ size_t len;
+ SCM prog, x;
+ struct scm_program *p;
+
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ prog = scm_c_make_program (ip, len, program);
+ p = SCM_PROGRAM_DATA (prog);
+ ip += len;
+
+ POP (x);
+
+ /* init meta data */
+ if (SCM_CONSP (x))
+ {
+ p->meta = x;
+ POP (x);
+ }
+
+ /* init object table */
+ if (scm_is_vector (x))
+ {
+#if 0
+ if (scm_is_simple_vector (x))
+ printf ("is_simple_vector!\n");
+ else
+ printf ("NOT is_simple_vector\n");
+#endif
+ p->objs = x;
+ POP (x);
+ }
+
+ /* init parameters */
+ /* NOTE: format defined in system/vm/assemble.scm */
+ if (SCM_I_INUMP (x))
+ {
+ int i = SCM_I_INUM (x);
+ if (-128 <= i && i <= 127)
+ {
+ /* 8-bit representation */
+ p->nargs = (i >> 6) & 0x03; /* 7-6 bits */
+ p->nrest = (i >> 5) & 0x01; /* 5 bit */
+ p->nlocs = (i >> 2) & 0x07; /* 4-2 bits */
+ p->nexts = i & 0x03; /* 1-0 bits */
+ }
+ else
+ {
+ /* 16-bit representation */
+ p->nargs = (i >> 12) & 0x07; /* 15-12 bits */
+ p->nrest = (i >> 11) & 0x01; /* 11 bit */
+ p->nlocs = (i >> 4) & 0x7f; /* 10-04 bits */
+ p->nexts = i & 0x0f; /* 03-00 bits */
+ }
+ }
+ else
+ {
+ /* Other cases */
+ /* x is #f, and already popped off */
+ p->nargs = SCM_I_INUM (sp[-3]);
+ p->nrest = SCM_I_INUM (sp[-2]);
+ p->nlocs = SCM_I_INUM (sp[-1]);
+ p->nexts = SCM_I_INUM (sp[0]);
+ sp -= 4;
+ }
+
+ PUSH (prog);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1)
+{
+ SCM sym;
+ POP (sym);
+ SYNC_REGISTER ();
+ PUSH (scm_lookup (sym)); /* might longjmp */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (link_later, "link-later", 0, 2, 1)
+{
+ SCM modname, sym;
+ POP (sym);
+ POP (modname);
+ SYNC_REGISTER ();
+ PUSH (scm_cons (modname, sym));
+ NEXT;
+}
+
+VM_DEFINE_LOADER (define, "define")
+{
+ SCM sym;
+ size_t len;
+
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ sym = scm_from_locale_symboln ((char *)ip, len);
+ ip += len;
+
+ SYNC_REGISTER ();
+ PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T));
+ NEXT;
+}
+
+VM_DEFINE_LOADER (late_bind, "late-bind")
+{
+ SCM sym;
+ size_t len;
+
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ sym = scm_from_locale_symboln ((char *)ip, len);
+ ip += len;
+
+ PUSH (sym);
+ NEXT;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* This file is included in vm_engine.c */
+
+\f
+/*
+ * Predicates
+ */
+
+VM_DEFINE_FUNCTION (not, "not", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (not_not, "not-not", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (!SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (eq, "eq?", 2)
+{
+ ARGS2 (x, y);
+ RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
+{
+ ARGS2 (x, y);
+ RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (nullp, "null?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (!SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (eqv, "eqv?", 2)
+{
+ ARGS2 (x, y);
+ if (SCM_EQ_P (x, y))
+ RETURN (SCM_BOOL_T);
+ if (SCM_IMP (x) || SCM_IMP (y))
+ RETURN (SCM_BOOL_F);
+ SYNC_REGISTER ();
+ RETURN (scm_eqv_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (equal, "equal?", 2)
+{
+ ARGS2 (x, y);
+ if (SCM_EQ_P (x, y))
+ RETURN (SCM_BOOL_T);
+ if (SCM_IMP (x) || SCM_IMP (y))
+ RETURN (SCM_BOOL_F);
+ SYNC_REGISTER ();
+ RETURN (scm_equal_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (pairp, "pair?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_CONSP (x)));
+}
+
+VM_DEFINE_FUNCTION (listp, "list?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (scm_ilength (x) >= 0));
+}
+
+\f
+/*
+ * Basic data
+ */
+
+VM_DEFINE_FUNCTION (cons, "cons", 2)
+{
+ ARGS2 (x, y);
+ CONS (x, x, y);
+ RETURN (x);
+}
+
+VM_DEFINE_FUNCTION (car, "car", 1)
+{
+ ARGS1 (x);
+ SCM_VALIDATE_CONS (1, x);
+ RETURN (SCM_CAR (x));
+}
+
+VM_DEFINE_FUNCTION (cdr, "cdr", 1)
+{
+ ARGS1 (x);
+ SCM_VALIDATE_CONS (1, x);
+ RETURN (SCM_CDR (x));
+}
+
+VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
+{
+ ARGS2 (x, y);
+ SCM_VALIDATE_CONS (1, x);
+ SCM_SETCAR (x, y);
+ RETURN (SCM_UNSPECIFIED);
+}
+
+VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
+{
+ ARGS2 (x, y);
+ SCM_VALIDATE_CONS (1, x);
+ SCM_SETCDR (x, y);
+ RETURN (SCM_UNSPECIFIED);
+}
+
+\f
+/*
+ * Numeric relational tests
+ */
+
+#undef REL
+#define REL(crel,srel) \
+{ \
+ ARGS2 (x, y); \
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
+ RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y))); \
+ SYNC_REGISTER (); \
+ RETURN (srel (x, y)); \
+}
+
+VM_DEFINE_FUNCTION (ee, "ee?", 2)
+{
+ REL (==, scm_num_eq_p);
+}
+
+VM_DEFINE_FUNCTION (lt, "lt?", 2)
+{
+ REL (<, scm_less_p);
+}
+
+VM_DEFINE_FUNCTION (le, "le?", 2)
+{
+ REL (<=, scm_leq_p);
+}
+
+VM_DEFINE_FUNCTION (gt, "gt?", 2)
+{
+ REL (>, scm_gr_p);
+}
+
+VM_DEFINE_FUNCTION (ge, "ge?", 2)
+{
+ REL (>=, scm_geq_p);
+}
+
+\f
+/*
+ * Numeric functions
+ */
+
+#undef FUNC1
+#define FUNC1(CEXP,SEXP) \
+{ \
+ ARGS1 (x); \
+ if (SCM_I_INUMP (x)) \
+ { \
+ int n = CEXP; \
+ if (SCM_FIXABLE (n)) \
+ RETURN (SCM_I_MAKINUM (n)); \
+ } \
+ SYNC_REGISTER (); \
+ RETURN (SEXP); \
+}
+
+#undef FUNC2
+#define FUNC2(CFUNC,SFUNC) \
+{ \
+ ARGS2 (x, y); \
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
+ { \
+ int n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
+ if (SCM_FIXABLE (n)) \
+ RETURN (SCM_I_MAKINUM (n)); \
+ } \
+ SYNC_REGISTER (); \
+ RETURN (SFUNC (x, y)); \
+}
+
+VM_DEFINE_FUNCTION (add, "add", 2)
+{
+ FUNC2 (+, scm_sum);
+}
+
+VM_DEFINE_FUNCTION (sub, "sub", 2)
+{
+ FUNC2 (-, scm_difference);
+}
+
+VM_DEFINE_FUNCTION (mul, "mul", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_product (x, y));
+}
+
+VM_DEFINE_FUNCTION (div, "div", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_divide (x, y));
+}
+
+VM_DEFINE_FUNCTION (quo, "quo", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_quotient (x, y));
+}
+
+VM_DEFINE_FUNCTION (rem, "rem", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_remainder (x, y));
+}
+
+VM_DEFINE_FUNCTION (mod, "mod", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_modulo (x, y));
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* This file is included in vm_engine.c */
+
+\f
+/*
+ * Basic operations
+ */
+
+/* This must be the first instruction! */
+VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
+{
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
+{
+ SCM ret;
+ vp->time += scm_c_get_internal_run_time () - start_time;
+ HALT_HOOK ();
+ POP (ret);
+ FREE_FRAME ();
+ SYNC_ALL ();
+ vp->ip = NULL;
+ scm_dynwind_end ();
+ return ret;
+}
+
+VM_DEFINE_INSTRUCTION (break, "break", 0, 0, 0)
+{
+ BREAK_HOOK ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
+{
+ DROP ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
+{
+ PUSH (SCM_UNDEFINED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
+{
+ SCM x = *sp;
+ PUSH (x);
+ NEXT;
+}
+
+\f
+/*
+ * Object creation
+ */
+
+VM_DEFINE_INSTRUCTION (void, "void", 0, 0, 1)
+{
+ PUSH (SCM_UNSPECIFIED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_true, "make-true", 0, 0, 1)
+{
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_false, "make-false", 0, 0, 1)
+{
+ PUSH (SCM_BOOL_F);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1)
+{
+ PUSH (SCM_EOL);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1)
+{
+ PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1)
+{
+ PUSH (SCM_INUM0);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1)
+{
+ PUSH (SCM_I_MAKINUM (1));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1)
+{
+ int h = FETCH ();
+ int l = FETCH ();
+ PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
+{
+ PUSH (SCM_MAKE_CHAR (FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ unsigned len = ((h << 8) + l);
+ POP_LIST (len);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ unsigned len = ((h << 8) + l);
+ POP_LIST (len);
+ *sp = scm_vector (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0)
+{
+ POP_LIST_MARK ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
+{
+ POP_LIST_MARK ();
+ *sp = scm_vector (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
+{
+ SCM l;
+ POP (l);
+ for (; !SCM_NULLP (l); l = SCM_CDR (l))
+ PUSH (SCM_CAR (l));
+ NEXT;
+}
+
+\f
+/*
+ * Variable access
+ */
+
+#define OBJECT_REF(i) objects[i]
+#define OBJECT_SET(i,o) objects[i] = o
+
+#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
+#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
+
+/* For the variable operations, we _must_ obviously avoid function calls to
+ `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
+ nothing more than the corresponding macros. */
+#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
+#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
+#define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED)
+
+/* ref */
+
+VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
+{
+ register unsigned objnum = FETCH ();
+ CHECK_OBJECT (objnum);
+ PUSH (OBJECT_REF (objnum));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1)
+{
+ PUSH (LOCAL_REF (FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1)
+{
+ unsigned int i;
+ SCM e = external;
+ for (i = FETCH (); i; i--)
+ {
+ CHECK_EXTERNAL(e);
+ e = SCM_CDR (e);
+ }
+ CHECK_EXTERNAL(e);
+ PUSH (SCM_CAR (e));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
+{
+ SCM x = *sp;
+
+ if (!VARIABLE_BOUNDP (x))
+ {
+ err_args = SCM_LIST1 (x);
+ /* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */
+ goto vm_error_unbound;
+ }
+ else
+ {
+ SCM o = VARIABLE_REF (x);
+ *sp = o;
+ }
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
+{
+ unsigned objnum = FETCH ();
+ SCM pair_or_var;
+ CHECK_OBJECT (objnum);
+ pair_or_var = OBJECT_REF (objnum);
+
+ if (!SCM_VARIABLEP (pair_or_var))
+ {
+ SYNC_REGISTER ();
+ /* either one of these calls might longjmp */
+ SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+ pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+ OBJECT_SET (objnum, pair_or_var);
+ if (!VARIABLE_BOUNDP (pair_or_var))
+ {
+ err_args = SCM_LIST1 (pair_or_var);
+ goto vm_error_unbound;
+ }
+ }
+
+ PUSH (VARIABLE_REF (pair_or_var));
+ NEXT;
+}
+
+/* set */
+
+VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0)
+{
+ LOCAL_SET (FETCH (), *sp);
+ DROP ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
+{
+ unsigned int i;
+ SCM e = external;
+ for (i = FETCH (); i; i--)
+ {
+ CHECK_EXTERNAL(e);
+ e = SCM_CDR (e);
+ }
+ CHECK_EXTERNAL(e);
+ SCM_SETCAR (e, *sp);
+ DROP ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
+{
+ VARIABLE_SET (sp[0], sp[-1]);
+ sp -= 2;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
+{
+ unsigned objnum = FETCH ();
+ SCM pair_or_var;
+ CHECK_OBJECT (objnum);
+ pair_or_var = OBJECT_REF (objnum);
+
+ if (!SCM_VARIABLEP (pair_or_var))
+ {
+ SYNC_BEFORE_GC ();
+ SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+ /* module_lookup might longjmp */
+ pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+ OBJECT_SET (objnum, pair_or_var);
+ }
+
+ VARIABLE_SET (pair_or_var, *sp);
+ DROP ();
+ NEXT;
+}
+
+\f
+/*
+ * branch and jump
+ */
+
+#define BR(p) \
+{ \
+ int h = FETCH (); \
+ int l = FETCH (); \
+ signed short offset = (h << 8) + l; \
+ if (p) \
+ ip += offset; \
+ DROP (); \
+ NEXT; \
+}
+
+VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
+{
+ int h = FETCH ();
+ int l = FETCH ();
+ ip += (signed short) (h << 8) + l;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0)
+{
+ BR (!SCM_FALSEP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0)
+{
+ BR (SCM_FALSEP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0)
+{
+ BR (SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+{
+ BR (!SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0)
+{
+ BR (SCM_NULLP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
+{
+ BR (!SCM_NULLP (*sp));
+}
+
+\f
+/*
+ * Subprogram call
+ */
+
+VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
+{
+ SYNC_BEFORE_GC ();
+ *sp = scm_c_make_closure (*sp, external);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
+{
+ SCM x;
+ nargs = FETCH ();
+
+ vm_call:
+ x = sp[-nargs];
+
+ /*
+ * Subprogram call
+ */
+ if (SCM_PROGRAM_P (x))
+ {
+ program = x;
+ vm_call_program:
+ CACHE_PROGRAM ();
+ INIT_ARGS ();
+ NEW_FRAME ();
+ ENTER_HOOK ();
+ APPLY_HOOK ();
+ NEXT;
+ }
+#ifdef ENABLE_TRAMPOLINE
+ /* Seems to slow down the fibo test, dunno why */
+ /*
+ * Subr call
+ */
+ switch (nargs)
+ {
+ case 0:
+ {
+ scm_t_trampoline_0 call = scm_trampoline_0 (x);
+ if (call)
+ {
+ SYNC_ALL ();
+ *sp = call (x);
+ NEXT;
+ }
+ break;
+ }
+ case 1:
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (x);
+ if (call)
+ {
+ SCM arg1;
+ POP (arg1);
+ SYNC_ALL ();
+ *sp = call (x, arg1);
+ NEXT;
+ }
+ break;
+ }
+ case 2:
+ {
+ scm_t_trampoline_2 call = scm_trampoline_2 (x);
+ if (call)
+ {
+ SCM arg1, arg2;
+ POP (arg2);
+ POP (arg1);
+ SYNC_ALL ();
+ *sp = call (x, arg1, arg2);
+ NEXT;
+ }
+ break;
+ }
+ }
+#endif
+ /*
+ * Other interpreted or compiled call
+ */
+ if (!SCM_FALSEP (scm_procedure_p (x)))
+ {
+ /* At this point, the stack contains the procedure and each one of its
+ arguments. */
+ SCM args;
+ POP_LIST (nargs);
+ POP (args);
+ SYNC_REGISTER ();
+ *sp = scm_apply (x, args, SCM_EOL);
+ NEXT;
+ }
+ /*
+ * Continuation call
+ */
+ if (SCM_VM_CONT_P (x))
+ {
+ program = x;
+ vm_call_cc:
+ /* Check the number of arguments */
+ if (nargs != 1)
+ scm_wrong_num_args (program);
+
+ /* Reinstate the continuation */
+ EXIT_HOOK ();
+ reinstate_vm_cont (vp, program);
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ NEXT;
+ }
+
+ program = x;
+ goto vm_error_wrong_type_apply;
+}
+
+VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
+{
+ register SCM x;
+ nargs = FETCH ();
+ x = sp[-nargs];
+
+ SCM_TICK; /* allow interrupt here */
+
+ /*
+ * Tail recursive call
+ */
+ if (SCM_EQ_P (x, program))
+ {
+ int i;
+
+ /* Move arguments */
+ INIT_ARGS ();
+ sp -= bp->nargs - 1;
+ for (i = 0; i < bp->nargs; i++)
+ LOCAL_SET (i, sp[i]);
+
+ /* Drop the first argument and the program itself. */
+ sp -= 2;
+
+ /* Call itself */
+ ip = bp->base;
+ APPLY_HOOK ();
+ NEXT;
+ }
+ /*
+ * Proper tail call
+ */
+ if (SCM_PROGRAM_P (x))
+ {
+ EXIT_HOOK ();
+ FREE_FRAME ();
+ program = x;
+ goto vm_call_program;
+ }
+#ifdef ENABLE_TRAMPOLINE
+ /* This seems to actually slow down the fibo test -- dunno why */
+ /*
+ * Subr call
+ */
+ switch (nargs)
+ {
+ case 0:
+ {
+ scm_t_trampoline_0 call = scm_trampoline_0 (x);
+ if (call)
+ {
+ SYNC_ALL ();
+ *sp = call (x);
+ goto vm_return;
+ }
+ break;
+ }
+ case 1:
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (x);
+ if (call)
+ {
+ SCM arg1;
+ POP (arg1);
+ SYNC_ALL ();
+ *sp = call (x, arg1);
+ goto vm_return;
+ }
+ break;
+ }
+ case 2:
+ {
+ scm_t_trampoline_2 call = scm_trampoline_2 (x);
+ if (call)
+ {
+ SCM arg1, arg2;
+ POP (arg2);
+ POP (arg1);
+ SYNC_ALL ();
+ *sp = call (x, arg1, arg2);
+ goto vm_return;
+ }
+ break;
+ }
+ }
+#endif
+
+ /*
+ * Other interpreted or compiled call
+ */
+ if (!SCM_FALSEP (scm_procedure_p (x)))
+ {
+ SCM args;
+ POP_LIST (nargs);
+ POP (args);
+ SYNC_REGISTER ();
+ *sp = scm_apply (x, args, SCM_EOL);
+ goto vm_return;
+ }
+
+ program = x;
+
+ /*
+ * Continuation call
+ */
+ if (SCM_VM_CONT_P (program))
+ goto vm_call_cc;
+
+ goto vm_error_wrong_type_apply;
+}
+
+VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
+{
+ int len;
+ SCM ls;
+ POP (ls);
+
+ nargs = FETCH ();
+ if (nargs < 2)
+ goto vm_error_wrong_num_args;
+
+ len = scm_ilength (ls);
+ if (len < 0)
+ goto vm_error_wrong_type_arg;
+
+ for (; !SCM_NULLP (ls); ls = SCM_CDR (ls))
+ PUSH (SCM_CAR (ls));
+
+ nargs += len - 2;
+ goto vm_call;
+}
+
+VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
+{
+ SYNC_BEFORE_GC ();
+ PUSH (capture_vm_cont (vp));
+ POP (program);
+ nargs = 1;
+ goto vm_call;
+}
+
+VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
+{
+ vm_return:
+ EXIT_HOOK ();
+ RETURN_HOOK ();
+ FREE_FRAME ();
+
+ /* Restore the last program */
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ CACHE_EXTERNAL ();
+ CHECK_IP ();
+ NEXT;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "frames.h"
+#include "instructions.h"
+#include "objcodes.h"
+#include "programs.h"
+#include "vm.h"
+
+/* I sometimes use this for debugging. */
+#define vm_puts(OBJ) \
+{ \
+ scm_display (OBJ, scm_current_error_port ()); \
+ scm_newline (scm_current_error_port ()); \
+}
+
+\f
+/*
+ * VM Continuation
+ */
+
+scm_t_bits scm_tc16_vm_cont;
+
+
+#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
+#define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
+
+static SCM
+capture_vm_cont (struct scm_vm *vp)
+{
+ struct scm_vm *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+ p->stack_size = vp->stack_limit - vp->sp;
+ p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
+ "capture_vm_cont");
+ p->stack_limit = p->stack_base + p->stack_size - 2;
+ p->ip = vp->ip;
+ p->sp = (SCM *) (vp->stack_limit - vp->sp);
+ p->fp = (SCM *) (vp->stack_limit - vp->fp);
+ memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM));
+ SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
+}
+
+static void
+reinstate_vm_cont (struct scm_vm *vp, SCM cont)
+{
+ struct scm_vm *p = SCM_VM_CONT_VP (cont);
+ if (vp->stack_size < p->stack_size)
+ {
+ /* puts ("FIXME: Need to expand"); */
+ abort ();
+ }
+ vp->ip = p->ip;
+ vp->sp = vp->stack_limit - (int) p->sp;
+ vp->fp = vp->stack_limit - (int) p->fp;
+ memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
+}
+
+struct vm_unwind_data
+{
+ struct scm_vm *vp;
+ SCM *sp;
+ SCM *fp;
+ SCM this_frame;
+};
+
+static void
+vm_reset_stack (void *data)
+{
+ struct vm_unwind_data *w = data;
+
+ w->vp->sp = w->sp;
+ w->vp->fp = w->fp;
+ w->vp->this_frame = w->this_frame;
+}
+
+static SCM
+vm_cont_mark (SCM obj)
+{
+ SCM *p;
+ struct scm_vm *vp = SCM_VM_CONT_VP (obj);
+ for (p = vp->stack_base; p <= vp->stack_limit; p++)
+ if (SCM_NIMP (*p))
+ scm_gc_mark (*p);
+ return SCM_BOOL_F;
+}
+
+static scm_sizet
+vm_cont_free (SCM obj)
+{
+ struct scm_vm *p = SCM_VM_CONT_VP (obj);
+
+ scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
+ scm_gc_free (p, sizeof (struct scm_vm), "vm");
+
+ return 0;
+}
+
+\f
+/*
+ * VM Internal functions
+ */
+
+SCM_SYMBOL (sym_vm_run, "vm-run");
+SCM_SYMBOL (sym_vm_error, "vm-error");
+
+static scm_byte_t *
+vm_fetch_length (scm_byte_t *ip, size_t *lenp)
+{
+ /* NOTE: format defined in system/vm/conv.scm */
+ *lenp = *ip++;
+ if (*lenp < 254)
+ return ip;
+ else if (*lenp == 254)
+ {
+ int b1 = *ip++;
+ int b2 = *ip++;
+ *lenp = (b1 << 8) + b2;
+ }
+ else
+ {
+ int b1 = *ip++;
+ int b2 = *ip++;
+ int b3 = *ip++;
+ int b4 = *ip++;
+ *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
+ }
+ return ip;
+}
+
+static SCM
+vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
+{
+ SCM frame;
+ SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
+#if 0
+ SCM *src = SCM_FRAME_UPPER_ADDRESS (fp);
+#endif
+ SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp);
+
+ if (!dl)
+ {
+ /* The top frame */
+ frame = scm_c_make_heap_frame (fp);
+ fp = SCM_HEAP_FRAME_POINTER (frame);
+ SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
+ }
+ else
+ {
+ /* Child frames */
+ SCM link = SCM_FRAME_HEAP_LINK (dl);
+ if (!SCM_FALSEP (link))
+ link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
+ else
+ link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest);
+ frame = scm_c_make_heap_frame (fp);
+ fp = SCM_HEAP_FRAME_POINTER (frame);
+ SCM_FRAME_HEAP_LINK (fp) = link;
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
+ }
+
+ /* Apparently the intention here is to be able to have a frame on the heap,
+ but data on the stack, so that you can push as much as you want on the
+ stack; but I think that it's currently causing borkage with nonlocal exits
+ and the unwind handler, which reinstates the sp and fp, but it's no longer
+ pointing at a valid stack frame. So disable for now, we'll get back to
+ this later. */
+#if 0
+ /* Move stack data */
+ for (; src <= sp; src++, dest++)
+ *dest = *src;
+ *destp = dest;
+#endif
+
+ return frame;
+}
+
+static SCM
+vm_heapify_frames (SCM vm)
+{
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+ if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
+ {
+ SCM *dest;
+ vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
+ vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
+ vp->sp = dest - 1;
+ }
+ return vp->this_frame;
+}
+
+\f
+/*
+ * VM
+ */
+
+#define VM_DEFAULT_STACK_SIZE (16 * 1024)
+
+#define VM_REGULAR_ENGINE 0
+#define VM_DEBUG_ENGINE 1
+
+#if 0
+#define VM_NAME vm_regular_engine
+#define VM_ENGINE VM_REGULAR_ENGINE
+#include "vm-engine.c"
+#undef VM_NAME
+#undef VM_ENGINE
+#endif
+
+#define VM_NAME vm_debug_engine
+#define VM_ENGINE VM_DEBUG_ENGINE
+#include "vm-engine.c"
+#undef VM_NAME
+#undef VM_ENGINE
+
+scm_t_bits scm_tc16_vm;
+
+static SCM the_vm;
+
+static SCM
+make_vm (void)
+#define FUNC_NAME "make_vm"
+{
+ int i;
+ struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+
+ vp->stack_size = VM_DEFAULT_STACK_SIZE;
+ vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
+ "stack-base");
+ vp->stack_limit = vp->stack_base + vp->stack_size - 3;
+ vp->ip = NULL;
+ vp->sp = vp->stack_base - 1;
+ vp->fp = NULL;
+ vp->time = 0;
+ vp->clock = 0;
+ vp->options = SCM_EOL;
+ vp->this_frame = SCM_BOOL_F;
+ vp->last_frame = SCM_BOOL_F;
+ vp->last_ip = NULL;
+ for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+ vp->hooks[i] = SCM_BOOL_F;
+ SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
+}
+#undef FUNC_NAME
+
+static SCM
+vm_mark (SCM obj)
+{
+ int i;
+ struct scm_vm *vp = SCM_VM_DATA (obj);
+
+ /* mark the stack conservatively */
+ scm_mark_locations ((SCM_STACKITEM *) vp->stack_base,
+ sizeof (SCM) * (vp->sp - vp->stack_base + 1));
+
+ /* mark other objects */
+ for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+ scm_gc_mark (vp->hooks[i]);
+ scm_gc_mark (vp->this_frame);
+ scm_gc_mark (vp->last_frame);
+ return vp->options;
+}
+
+static scm_sizet
+vm_free (SCM obj)
+{
+ struct scm_vm *vp = SCM_VM_DATA (obj);
+
+ scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
+ "stack-base");
+ scm_gc_free (vp, sizeof (struct scm_vm), "vm");
+
+ return 0;
+}
+
+SCM_SYMBOL (sym_debug, "debug");
+
+SCM
+scm_vm_apply (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "scm_vm_apply"
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return vm_run (vm, program, args);
+}
+#undef FUNC_NAME
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_vm_version
+{
+ return scm_from_locale_string (PACKAGE_VERSION);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_the_vm
+{
+ return the_vm;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_vm_p
+{
+ return SCM_BOOL (SCM_VM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_make_vm,
+{
+ return make_vm ();
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_ip
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_sp
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fp
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
+}
+#undef FUNC_NAME
+
+#define VM_DEFINE_HOOK(n) \
+{ \
+ struct scm_vm *vp; \
+ SCM_VALIDATE_VM (1, vm); \
+ vp = SCM_VM_DATA (vm); \
+ if (SCM_FALSEP (vp->hooks[n])) \
+ vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
+ return vp->hooks[n]; \
+}
+
+SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_boot_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_halt_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_next_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_break_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_enter_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_apply_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_exit_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_return_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
+ (SCM vm, SCM key),
+ "")
+#define FUNC_NAME s_scm_vm_option
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
+ (SCM vm, SCM key, SCM val),
+ "")
+#define FUNC_NAME s_scm_set_vm_option_x
+{
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VM_DATA (vm)->options
+ = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_stats
+{
+ SCM stats;
+
+ SCM_VALIDATE_VM (1, vm);
+
+ stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
+ scm_vector_set_x (stats, SCM_I_MAKINUM (0),
+ scm_from_ulong (SCM_VM_DATA (vm)->time));
+ scm_vector_set_x (stats, SCM_I_MAKINUM (1),
+ scm_from_ulong (SCM_VM_DATA (vm)->clock));
+
+ return stats;
+}
+#undef FUNC_NAME
+
+#define VM_CHECK_RUNNING(vm) \
+ if (!SCM_VM_DATA (vm)->ip) \
+ SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
+
+SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_this_frame
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->this_frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_last_frame
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->last_frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_last_ip
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_save_stack
+{
+ struct scm_vm *vp;
+ SCM *dest;
+ SCM_VALIDATE_VM (1, vm);
+ vp = SCM_VM_DATA (vm);
+
+ if (vp->fp)
+ {
+ vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
+ vp->last_ip = vp->ip;
+ }
+ else
+ {
+ vp->last_frame = SCM_BOOL_F;
+ }
+
+
+ return vp->last_frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fetch_code
+{
+ int i;
+ SCM list;
+ scm_byte_t *ip;
+ struct scm_instruction *p;
+
+ SCM_VALIDATE_VM (1, vm);
+ VM_CHECK_RUNNING (vm);
+
+ ip = SCM_VM_DATA (vm)->ip;
+ p = SCM_INSTRUCTION (*ip);
+
+ list = SCM_LIST1 (scm_str2symbol (p->name));
+ for (i = 1; i <= p->len; i++)
+ list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
+ return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fetch_stack
+{
+ SCM *sp;
+ SCM ls = SCM_EOL;
+ struct scm_vm *vp;
+
+ SCM_VALIDATE_VM (1, vm);
+ VM_CHECK_RUNNING (vm);
+
+ vp = SCM_VM_DATA (vm);
+ for (sp = vp->stack_base; sp <= vp->sp; sp++)
+ ls = scm_cons (*sp, ls);
+ return ls;
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * Initialize
+ */
+
+SCM scm_load_compiled_with_vm (SCM file)
+{
+ SCM program = scm_objcode_to_program (scm_load_objcode (file));
+
+ return vm_run (the_vm, program, SCM_EOL);
+}
+
+void
+scm_bootstrap_vm (void)
+{
+ static int strappage = 0;
+
+ if (strappage)
+ return;
+
+ scm_bootstrap_frames ();
+ scm_bootstrap_instructions ();
+ scm_bootstrap_objcodes ();
+ scm_bootstrap_programs ();
+
+ scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
+ scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
+ scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
+
+ scm_tc16_vm = scm_make_smob_type ("vm", 0);
+ scm_set_smob_mark (scm_tc16_vm, vm_mark);
+ scm_set_smob_free (scm_tc16_vm, vm_free);
+ scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
+
+ the_vm = scm_permanent_object (make_vm ());
+
+ scm_c_define ("load-compiled",
+ scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
+ scm_load_compiled_with_vm));
+
+ strappage = 1;
+}
+
+void
+scm_init_vm (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "vm.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_VM_H_
+#define _SCM_VM_H_
+
+#include <libguile.h>
+
+#define SCM_VM_BOOT_HOOK 0
+#define SCM_VM_HALT_HOOK 1
+#define SCM_VM_NEXT_HOOK 2
+#define SCM_VM_BREAK_HOOK 3
+#define SCM_VM_ENTER_HOOK 4
+#define SCM_VM_APPLY_HOOK 5
+#define SCM_VM_EXIT_HOOK 6
+#define SCM_VM_RETURN_HOOK 7
+#define SCM_VM_NUM_HOOKS 8
+
+struct scm_vm {
+ scm_byte_t *ip; /* instruction pointer */
+ SCM *sp; /* stack pointer */
+ SCM *fp; /* frame pointer */
+ size_t stack_size; /* stack size */
+ SCM *stack_base; /* stack base address */
+ SCM *stack_limit; /* stack limit address */
+ SCM this_frame; /* currrent frame */
+ SCM last_frame; /* last frame */
+ scm_byte_t *last_ip; /* ip when exception occured */
+ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
+ SCM options; /* options */
+ unsigned long time; /* time spent */
+ unsigned long clock; /* bogos clock */
+};
+
+#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
+#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
+#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
+
+extern SCM scm_the_vm ();
+extern SCM scm_make_vm (void);
+extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
+extern SCM scm_vm_option_ref (SCM vm, SCM key);
+extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
+
+extern SCM scm_vm_version (void);
+extern SCM scm_the_vm (void);
+extern SCM scm_vm_p (SCM obj);
+extern SCM scm_vm_ip (SCM vm);
+extern SCM scm_vm_sp (SCM vm);
+extern SCM scm_vm_fp (SCM vm);
+extern SCM scm_vm_boot_hook (SCM vm);
+extern SCM scm_vm_halt_hook (SCM vm);
+extern SCM scm_vm_next_hook (SCM vm);
+extern SCM scm_vm_break_hook (SCM vm);
+extern SCM scm_vm_enter_hook (SCM vm);
+extern SCM scm_vm_apply_hook (SCM vm);
+extern SCM scm_vm_exit_hook (SCM vm);
+extern SCM scm_vm_return_hook (SCM vm);
+extern SCM scm_vm_option (SCM vm, SCM key);
+extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
+extern SCM scm_vm_stats (SCM vm);
+extern SCM scm_vm_this_frame (SCM vm);
+extern SCM scm_vm_last_frame (SCM vm);
+extern SCM scm_vm_last_ip (SCM vm);
+extern SCM scm_vm_save_stack (SCM vm);
+extern SCM scm_vm_fetch_code (SCM vm);
+extern SCM scm_vm_fetch_stack (SCM vm);
+
+extern SCM scm_load_compiled_with_vm (SCM file);
+
+extern void scm_init_vm (void);
+
+#endif /* _SCM_VM_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+dnl check for gcc's "labels as values" feature
+AC_DEFUN(AC_C_LABELS_AS_VALUES,
+[AC_CACHE_CHECK([labels as values], ac_cv_labels_as_values,
+[AC_TRY_COMPILE([
+int foo(int);
+int foo(i)
+int i; {
+static void *label[] = { &&l1, &&l2 };
+goto *label[i];
+l1: return 1;
+l2: return 2;
+}
+],
+[int i;],
+ac_cv_labels_as_values=yes,
+ac_cv_labels_as_values=no)])
+if test "$ac_cv_labels_as_values" = yes; then
+AC_DEFINE(HAVE_LABELS_AS_VALUES, [],
+ [Define if compiler supports gcc's "labels as values" (aka computed goto)
+ feature, used to speed up instruction dispatch in the interpreter.])
+fi
+])
--- /dev/null
+Makefile
+Makefile.in
+slibcat
--- /dev/null
+SUBDIRS = system language
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (lang elisp spec)
+ :use-module (system lang language)
+ :export (elisp))
+
+\f
+;;;
+;;; Translator
+;;;
+
+(define (translate x)
+ (if (pair? x)
+ (translate-pair x)
+ x))
+
+(define (translate-pair x)
+ (let ((name (car x)) (args (cdr x)))
+ (case name
+ ((quote) `(@quote ,@args))
+ ((defvar) `(@define ,@(map translate args)))
+ ((setq) `(@set! ,@(map translate args)))
+ ((if) `(@if ,(translate (car args))
+ (@begin ,@(map translate (cdr args)))))
+ ((and) `(@and ,@(map translate args)))
+ ((or) `(@or ,@(map translate args)))
+ ((progn) `(@begin ,@(map translate args)))
+ ((defun) `(@define ,(car args)
+ (@lambda ,(cadr args) ,@(map translate (cddr args)))))
+ ((lambda) `(@lambda ,(car args) ,@(map translate (cdr args))))
+ (else x))))
+
+\f
+;;;
+;;; Language definition
+;;;
+
+(define-language elisp
+ #:title "Emacs Lisp"
+ #:version "0.0"
+ #:reader read
+ #:expander id
+ #:translator translate
+ )
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+;;; GHIL package definition -*- gscheme -*-
+
+(define-package ghil
+ :category Language
+ :version "0.3"
+ :author "Keisuke Nishida <kxn30@po.cwru.edu>"
+ :modules ((spec "spec.scm" gscheme))
+ )
--- /dev/null
+;;; Guile High Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language ghil spec)
+ :use-module (system base language)
+ :export (ghil))
+
+(define-language ghil
+ :title "Guile High Intermediate Language (GHIL)"
+ :version "0.3"
+ :reader read
+ :printer write
+;; :environment (make-vmodule)
+ )
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+;;; r5rs package definition -*- gscheme -*-
+
+(define-package r5rs
+ :category Language
+ :version "0.3"
+ :author "Keisuke Nishida <kxn30@po.cwru.edu>"
+ :modules ((core "core.il" ghil)
+ (null "null.il" ghil)
+ (spec "spec.scm" gscheme)
+ (expand "expand.scm" gscheme)
+ (translate "translate.scm" gscheme))
+ )
--- /dev/null
+;;; R5RS core environment
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+;; Non standard procedures
+
+(@define void (@lambda () (@void)))
+
+;; 6. Standard procedures
+
+;;; 6.1 Equivalence predicates
+
+(@define eq? (@lambda (x y) (@eq? x y)))
+(@define eqv? (@ Core::eqv?))
+(@define equal? (@ Core::equal?))
+
+;;; 6.2 Numbers
+
+(@define number? (@ Core::number?))
+(@define complex? (@ Core::complex?))
+(@define real? (@ Core::real?))
+(@define rational? (@ Core::rational?))
+(@define integer? (@ Core::integer?))
+
+(@define exact? (@ Core::exact?))
+(@define inexact? (@ Core::inexact?))
+
+(@define = (@ Core::=))
+(@define < (@ Core::<))
+(@define > (@ Core::>))
+(@define <= (@ Core::<=))
+(@define >= (@ Core::>=))
+
+(@define zero? (@ Core::zero?))
+(@define positive? (@ Core::positive?))
+(@define negative? (@ Core::negative?))
+(@define odd? (@ Core::odd?))
+(@define even? (@ Core::even?))
+
+(@define max (@ Core::max))
+(@define min (@ Core::min))
+
+(@define + (@ Core::+))
+(@define * (@ Core::*))
+(@define - (@ Core::-))
+(@define / (@ Core::/))
+
+(@define abs (@ Core::abs))
+
+(@define quotient (@ Core::quotient))
+(@define remainder (@ Core::remainder))
+(@define modulo (@ Core::modulo))
+
+(@define gcd (@ Core::gcd))
+(@define lcm (@ Core::lcm))
+
+;; (@define numerator (@ Core::numerator))
+;; (@define denominator (@ Core::denominator))
+
+(@define floor (@ Core::floor))
+(@define ceiling (@ Core::ceiling))
+(@define truncate (@ Core::truncate))
+(@define round (@ Core::round))
+
+;; (@define rationalize (@ Core::rationalize))
+
+(@define exp (@ Core::exp))
+(@define log (@ Core::log))
+(@define sin (@ Core::sin))
+(@define cos (@ Core::cos))
+(@define tan (@ Core::tan))
+(@define asin (@ Core::asin))
+(@define acos (@ Core::acos))
+(@define atan (@ Core::atan))
+
+(@define sqrt (@ Core::sqrt))
+(@define expt (@ Core::expt))
+
+(@define make-rectangular (@ Core::make-rectangular))
+(@define make-polar (@ Core::make-polar))
+(@define real-part (@ Core::real-part))
+(@define imag-part (@ Core::imag-part))
+(@define magnitude (@ Core::magnitude))
+(@define angle (@ Core::angle))
+
+(@define exact->inexact (@ Core::exact->inexact))
+(@define inexact->exact (@ Core::inexact->exact))
+
+(@define number->string (@ Core::number->string))
+(@define string->number (@ Core::string->number))
+
+;;; 6.3 Other data types
+
+;;;; 6.3.1 Booleans
+
+(@define not (@lambda (x) (@not x)))
+(@define boolean? (@ Core::boolean?))
+
+;;;; 6.3.2 Pairs and lists
+
+(@define pair? (@lambda (x) (@pair? x)))
+(@define cons (@lambda (x y) (@cons x y)))
+
+(@define car (@lambda (x) (@car x)))
+(@define cdr (@lambda (x) (@cdr x)))
+(@define set-car! (@ Core::set-car!))
+(@define set-cdr! (@ Core::set-cdr!))
+
+(@define caar (@lambda (x) (@caar x)))
+(@define cadr (@lambda (x) (@cadr x)))
+(@define cdar (@lambda (x) (@cdar x)))
+(@define cddr (@lambda (x) (@cddr x)))
+(@define caaar (@lambda (x) (@caaar x)))
+(@define caadr (@lambda (x) (@caadr x)))
+(@define cadar (@lambda (x) (@cadar x)))
+(@define caddr (@lambda (x) (@caddr x)))
+(@define cdaar (@lambda (x) (@cdaar x)))
+(@define cdadr (@lambda (x) (@cdadr x)))
+(@define cddar (@lambda (x) (@cddar x)))
+(@define cdddr (@lambda (x) (@cdddr x)))
+(@define caaaar (@lambda (x) (@caaaar x)))
+(@define caaadr (@lambda (x) (@caaadr x)))
+(@define caadar (@lambda (x) (@caadar x)))
+(@define caaddr (@lambda (x) (@caaddr x)))
+(@define cadaar (@lambda (x) (@cadaar x)))
+(@define cadadr (@lambda (x) (@cadadr x)))
+(@define caddar (@lambda (x) (@caddar x)))
+(@define cadddr (@lambda (x) (@cadddr x)))
+(@define cdaaar (@lambda (x) (@cdaaar x)))
+(@define cdaadr (@lambda (x) (@cdaadr x)))
+(@define cdadar (@lambda (x) (@cdadar x)))
+(@define cdaddr (@lambda (x) (@cdaddr x)))
+(@define cddaar (@lambda (x) (@cddaar x)))
+(@define cddadr (@lambda (x) (@cddadr x)))
+(@define cdddar (@lambda (x) (@cdddar x)))
+(@define cddddr (@lambda (x) (@cddddr x)))
+
+(@define null? (@lambda (x) (@null? x)))
+(@define list? (@lambda (x) (@list? x)))
+
+(@define list (@lambda x x))
+
+(@define length (@ Core::length))
+(@define append (@ Core::append))
+(@define reverse (@ Core::reverse))
+(@define list-tail (@ Core::list-tail))
+(@define list-ref (@ Core::list-ref))
+
+(@define memq (@ Core::memq))
+(@define memv (@ Core::memv))
+(@define member (@ Core::member))
+
+(@define assq (@ Core::assq))
+(@define assv (@ Core::assv))
+(@define assoc (@ Core::assoc))
+
+;;;; 6.3.3 Symbols
+
+(@define symbol? (@ Core::symbol?))
+(@define symbol->string (@ Core::symbol->string))
+(@define string->symbol (@ Core::string->symbol))
+
+;;;; 6.3.4 Characters
+
+(@define char? (@ Core::char?))
+(@define char=? (@ Core::char=?))
+(@define char<? (@ Core::char<?))
+(@define char>? (@ Core::char>?))
+(@define char<=? (@ Core::char<=?))
+(@define char>=? (@ Core::char>=?))
+(@define char-ci=? (@ Core::char-ci=?))
+(@define char-ci<? (@ Core::char-ci<?))
+(@define char-ci>? (@ Core::char-ci>?))
+(@define char-ci<=? (@ Core::char-ci<=?))
+(@define char-ci>=? (@ Core::char-ci>=?))
+(@define char-alphabetic? (@ Core::char-alphabetic?))
+(@define char-numeric? (@ Core::char-numeric?))
+(@define char-whitespace? (@ Core::char-whitespace?))
+(@define char-upper-case? (@ Core::char-upper-case?))
+(@define char-lower-case? (@ Core::char-lower-case?))
+(@define char->integer (@ Core::char->integer))
+(@define integer->char (@ Core::integer->char))
+(@define char-upcase (@ Core::char-upcase))
+(@define char-downcase (@ Core::char-downcase))
+
+;;;; 6.3.5 Strings
+
+(@define string? (@ Core::string?))
+(@define make-string (@ Core::make-string))
+(@define string (@ Core::string))
+(@define string-length (@ Core::string-length))
+(@define string-ref (@ Core::string-ref))
+(@define string-set! (@ Core::string-set!))
+
+(@define string=? (@ Core::string=?))
+(@define string-ci=? (@ Core::string-ci=?))
+(@define string<? (@ Core::string<?))
+(@define string>? (@ Core::string>?))
+(@define string<=? (@ Core::string<=?))
+(@define string>=? (@ Core::string>=?))
+(@define string-ci<? (@ Core::string-ci<?))
+(@define string-ci>? (@ Core::string-ci>?))
+(@define string-ci<=? (@ Core::string-ci<=?))
+(@define string-ci>=? (@ Core::string-ci>=?))
+
+(@define substring (@ Core::substring))
+(@define string-append (@ Core::string-append))
+(@define string->list (@ Core::string->list))
+(@define list->string (@ Core::list->string))
+(@define string-copy (@ Core::string-copy))
+(@define string-fill! (@ Core::string-fill!))
+
+;;;; 6.3.6 Vectors
+
+(@define vector? (@ Core::vector?))
+(@define make-vector (@ Core::make-vector))
+(@define vector (@ Core::vector))
+(@define vector-length (@ Core::vector-length))
+(@define vector-ref (@ Core::vector-ref))
+(@define vector-set! (@ Core::vector-set!))
+(@define vector->list (@ Core::vector->list))
+(@define list->vector (@ Core::list->vector))
+(@define vector-fill! (@ Core::vector-fill!))
+
+;;; 6.4 Control features
+
+(@define procedure? (@ Core::procedure?))
+(@define apply (@ Core::apply))
+(@define map (@ Core::map))
+(@define for-each (@ Core::for-each))
+(@define force (@ Core::force))
+
+(@define call-with-current-continuation (@ Core::call-with-current-continuation))
+(@define values (@ Core::values))
+(@define call-with-values (@ Core::call-with-values))
+(@define dynamic-wind (@ Core::dynamic-wind))
+
+;;; 6.5 Eval
+
+(@define eval
+ (@let ((l (@ Language::r5rs::spec::r5rs)))
+ (@lambda (x e)
+ (((@ System::Base::language::compile-in) x e l)))))
+
+;; (@define scheme-report-environment
+;; (@lambda (version)
+;; (@if (@= version 5)
+;; (@ Language::R5RS::Core)
+;; (@error "Unsupported environment version" version))))
+;;
+;; (@define null-environment
+;; (@lambda (version)
+;; (@if (@= version 5)
+;; (@ Language::R5RS::Null)
+;; (@error "Unsupported environment version" version))))
+
+(@define interaction-environment (@lambda () (@current-module)))
+
+;;; 6.6 Input and output
+
+;;;; 6.6.1 Ports
+
+(@define call-with-input-file (@ Core::call-with-input-file))
+(@define call-with-output-file (@ Core::call-with-output-file))
+
+(@define input-port? (@ Core::input-port?))
+(@define output-port? (@ Core::output-port?))
+(@define current-input-port (@ Core::current-input-port))
+(@define current-output-port (@ Core::current-output-port))
+
+(@define with-input-from-file (@ Core::with-input-from-file))
+(@define with-output-to-file (@ Core::with-output-to-file))
+
+(@define open-input-file (@ Core::open-input-file))
+(@define open-output-file (@ Core::open-output-file))
+(@define close-input-port (@ Core::close-input-port))
+(@define close-output-port (@ Core::close-output-port))
+
+;;;; 6.6.2 Input
+
+(@define read (@ Core::read))
+(@define read-char (@ Core::read-char))
+(@define peek-char (@ Core::peek-char))
+(@define eof-object? (@ Core::eof-object?))
+(@define char-ready? (@ Core::char-ready?))
+
+;;;; 6.6.3 Output
+
+(@define write (@ Core::write))
+(@define display (@ Core::display))
+(@define newline (@ Core::newline))
+(@define write-char (@ Core::write-char))
+
+;;;; 6.6.4 System interface
+
+(@define load
+ (@lambda (file)
+ (call-with-input-file file
+ (@lambda (port)
+ (@let ((loop (@lambda (x)
+ (@if (@not (eof-object? x))
+ (@begin
+ (eval x (interaction-environment))
+ (loop (read port)))))))
+ (loop (read port)))))))
+
+;; transcript-on
+;; transcript-off
--- /dev/null
+;;; R5RS syntax expander
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language r5rs expand)
+ :export (expand void
+ identifier? free-identifier=? bound-identifier=?
+ generate-temporaries datum->syntax-object syntax-object->datum))
+
+(define sc-expand #f)
+(define $sc-put-cte #f)
+(define $syntax-dispatch #f)
+(define syntax-rules #f)
+(define syntax-error #f)
+(define identifier? #f)
+(define free-identifier=? #f)
+(define bound-identifier=? #f)
+(define generate-temporaries #f)
+(define datum->syntax-object #f)
+(define syntax-object->datum #f)
+
+(define void (lambda () (if #f #f)))
+
+(define andmap
+ (lambda (f first . rest)
+ (or (null? first)
+ (if (null? rest)
+ (let andmap ((first first))
+ (let ((x (car first)) (first (cdr first)))
+ (if (null? first)
+ (f x)
+ (and (f x) (andmap first)))))
+ (let andmap ((first first) (rest rest))
+ (let ((x (car first))
+ (xr (map car rest))
+ (first (cdr first))
+ (rest (map cdr rest)))
+ (if (null? first)
+ (apply f (cons x xr))
+ (and (apply f (cons x xr)) (andmap first rest)))))))))
+
+(define ormap
+ (lambda (proc list1)
+ (and (not (null? list1))
+ (or (proc (car list1)) (ormap proc (cdr list1))))))
+
+(define putprop set-symbol-property!)
+(define getprop symbol-property)
+(define remprop symbol-property-remove!)
+
+(define syncase-module (current-module))
+(define guile-eval eval)
+(define (eval x)
+ (if (and (pair? x) (equal? (car x) "noexpand"))
+ (cdr x)
+ (guile-eval x syncase-module)))
+
+(define guile-error error)
+(define (error who format-string why what)
+ (guile-error why what))
+
+(load "psyntax.pp")
+
+(define expand sc-expand)
--- /dev/null
+;;; R5RS null environment
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
--- /dev/null
+;;; psyntax.pp
+;;; automatically generated from psyntax.ss
+;;; Wed Aug 30 12:24:52 EST 2000
+;;; see copyright notice in psyntax.ss
+
+((lambda ()
+ (letrec ((g452
+ (lambda (g1823)
+ ((letrec ((g1824
+ (lambda (g1827 g1825 g1826)
+ (if (pair? g1827)
+ (g1824
+ (cdr g1827)
+ (cons (g393 (car g1827) g1826) g1825)
+ g1826)
+ (if (g256 g1827)
+ (cons (g393 g1827 g1826) g1825)
+ (if (null? g1827)
+ g1825
+ (if (g204 g1827)
+ (g1824
+ (g205 g1827)
+ g1825
+ (g371 g1826 (g206 g1827)))
+ (if (g90 g1827)
+ (g1824
+ (annotation-expression
+ g1827)
+ g1825
+ g1826)
+ (cons g1827 g1825)))))))))
+ g1824)
+ g1823
+ '()
+ '(()))))
+ (g451
+ (lambda (g833)
+ ((lambda (g834) (if (g90 g834) (gensym) (gensym)))
+ (if (g204 g833) (g205 g833) g833))))
+ (g450
+ (lambda (g1820 g1819)
+ (g449 g1820
+ g1819
+ (lambda (g1821)
+ (if ((lambda (g1822)
+ (if g1822
+ g1822
+ (if (pair? g1821)
+ (g90 (car g1821))
+ '#f)))
+ (g90 g1821))
+ (g448 g1821 '#f)
+ g1821)))))
+ (g449
+ (lambda (g837 g835 g836)
+ (if (memq 'top (g264 g835))
+ (g836 g837)
+ ((letrec ((g838
+ (lambda (g839)
+ (if (g204 g839)
+ (g449 (g205 g839) (g206 g839) g836)
+ (if (pair? g839)
+ ((lambda (g841 g840)
+ (if (if (eq? g841 (car g839))
+ (eq? g840 (cdr g839))
+ '#f)
+ g839
+ (cons g841 g840)))
+ (g838 (car g839))
+ (g838 (cdr g839)))
+ (if (vector? g839)
+ ((lambda (g842)
+ ((lambda (g843)
+ (if (andmap
+ eq?
+ g842
+ g843)
+ g839
+ (list->vector g843)))
+ (map g838 g842)))
+ (vector->list g839))
+ g839))))))
+ g838)
+ g837))))
+ (g448
+ (lambda (g1813 g1812)
+ (if (pair? g1813)
+ ((lambda (g1814)
+ (begin (if g1812
+ (set-annotation-stripped! g1812 g1814)
+ (void))
+ (set-car! g1814 (g448 (car g1813) '#f))
+ (set-cdr! g1814 (g448 (cdr g1813) '#f))
+ g1814))
+ (cons '#f '#f))
+ (if (g90 g1813)
+ ((lambda (g1815)
+ (if g1815
+ g1815
+ (g448 (annotation-expression g1813) g1813)))
+ (annotation-stripped g1813))
+ (if (vector? g1813)
+ ((lambda (g1816)
+ (begin (if g1812
+ (set-annotation-stripped!
+ g1812
+ g1816)
+ (void))
+ ((letrec ((g1817
+ (lambda (g1818)
+ (if (not (< g1818 '0))
+ (begin (vector-set!
+ g1816
+ g1818
+ (g448 (vector-ref
+ g1813
+ g1818)
+ '#f))
+ (g1817
+ (- g1818
+ '1)))
+ (void)))))
+ g1817)
+ (- (vector-length g1813) '1))
+ g1816))
+ (make-vector (vector-length g1813)))
+ g1813)))))
+ (g447
+ (lambda (g844)
+ (if (g255 g844)
+ (g378 g844
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage ((import-token . *top*)) () ())
+ #(ribcage ((import-token . *top*)) () ()))))
+ '#f)))
+ (g446 (lambda () (list 'void)))
+ (g445
+ (lambda (g850 g845 g849 g846 g848 g847)
+ ((lambda (g851)
+ ((lambda (g852)
+ (if g852
+ (apply
+ (lambda (g857 g853 g856 g854 g855)
+ ((lambda (g858)
+ (if (not (g389 g858))
+ (g391 (map (lambda (g859)
+ (g393 g859 g846))
+ g858)
+ (g394 g845 g846 g848)
+ '"keyword")
+ ((lambda (g860)
+ ((lambda (g861)
+ (g847 (cons g854 g855)
+ (g247 g860
+ ((lambda (g863 g862)
+ (map (lambda (g865)
+ (g231 'deferred
+ (g432 g865
+ g862
+ g863)))
+ g856))
+ (if g850 g861 g846)
+ (g249 g849))
+ g849)
+ g861
+ g848))
+ (g368 g858 g860 g846)))
+ (g299 g858))))
+ g853))
+ g852)
+ ((lambda (g868)
+ (syntax-error (g394 g845 g846 g848)))
+ g851)))
+ ($syntax-dispatch
+ g851
+ '(any #(each (any any)) any . each-any))))
+ g845)))
+ (g444
+ (lambda (g1789 g1785 g1788 g1786 g1787)
+ ((lambda (g1790)
+ ((lambda (g1791)
+ (if g1791
+ (apply
+ (lambda (g1794 g1792 g1793)
+ ((lambda (g1795)
+ (if (not (g389 g1795))
+ (syntax-error
+ g1789
+ '"invalid parameter list in")
+ ((lambda (g1797 g1796)
+ (g1787
+ g1796
+ (g437 (cons g1792 g1793)
+ g1789
+ (g248 g1797 g1796 g1788)
+ (g368 g1795 g1797 g1786))))
+ (g299 g1795)
+ (map g451 g1795))))
+ g1794))
+ g1791)
+ ((lambda (g1800)
+ (if g1800
+ (apply
+ (lambda (g1803 g1801 g1802)
+ ((lambda (g1804)
+ (if (not (g389 g1804))
+ (syntax-error
+ g1789
+ '"invalid parameter list in")
+ ((lambda (g1806 g1805)
+ (g1787
+ ((letrec ((g1808
+ (lambda (g1810
+ g1809)
+ (if (null?
+ g1810)
+ g1809
+ (g1808
+ (cdr g1810)
+ (cons (car g1810)
+ g1809))))))
+ g1808)
+ (cdr g1805)
+ (car g1805))
+ (g437 (cons g1801 g1802)
+ g1789
+ (g248 g1806
+ g1805
+ g1788)
+ (g368 g1804
+ g1806
+ g1786))))
+ (g299 g1804)
+ (map g451 g1804))))
+ (g452 g1803)))
+ g1800)
+ ((lambda (g1811) (syntax-error g1789))
+ g1790)))
+ ($syntax-dispatch g1790 '(any any . each-any)))))
+ ($syntax-dispatch g1790 '(each-any any . each-any))))
+ g1785)))
+ (g443
+ (lambda (g872 g869 g871 g870)
+ ((lambda (g873)
+ ((lambda (g874)
+ (if (if g874
+ (apply
+ (lambda (g877 g875 g876) (g256 g875))
+ g874)
+ '#f)
+ (apply
+ (lambda (g880 g878 g879) (g870 g878 g879 g869))
+ g874)
+ ((lambda (g881)
+ (syntax-error (g394 g872 g869 g871)))
+ g873)))
+ ($syntax-dispatch g873 '(any any any))))
+ g872)))
+ (g442
+ (lambda (g1758 g1755 g1757 g1756)
+ ((lambda (g1759)
+ ((lambda (g1760)
+ (if (if g1760
+ (apply
+ (lambda (g1763 g1761 g1762) (g256 g1761))
+ g1760)
+ '#f)
+ (apply
+ (lambda (g1766 g1764 g1765)
+ (g1756 g1764 g1765 g1755))
+ g1760)
+ ((lambda (g1767)
+ (if (if g1767
+ (apply
+ (lambda (g1772
+ g1768
+ g1771
+ g1769
+ g1770)
+ (if (g256 g1768)
+ (g389 (g452 g1771))
+ '#f))
+ g1767)
+ '#f)
+ (apply
+ (lambda (g1777 g1773 g1776 g1774 g1775)
+ (g1756
+ (g393 g1773 g1755)
+ (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ name args e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e w s k)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (g393 (cons g1776
+ (cons g1774 g1775))
+ g1755))
+ '(())))
+ g1767)
+ ((lambda (g1779)
+ (if (if g1779
+ (apply
+ (lambda (g1781 g1780)
+ (g256 g1780))
+ g1779)
+ '#f)
+ (apply
+ (lambda (g1783 g1782)
+ (g1756
+ (g393 g1782 g1755)
+ '(#(syntax-object
+ void
+ ((top)
+ #(ribcage
+ #(_ name)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e w s k)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ '(())))
+ g1779)
+ ((lambda (g1784)
+ (syntax-error
+ (g394 g1758 g1755 g1757)))
+ g1759)))
+ ($syntax-dispatch g1759 '(any any)))))
+ ($syntax-dispatch
+ g1759
+ '(any (any . any) any . each-any)))))
+ ($syntax-dispatch g1759 '(any any any))))
+ g1758)))
+ (g441
+ (lambda (g885 g882 g884 g883)
+ ((lambda (g886)
+ ((lambda (g887)
+ (if (if g887
+ (apply (lambda (g889 g888) (g256 g888)) g887)
+ '#f)
+ (apply
+ (lambda (g891 g890) (g883 (g393 g890 g882)))
+ g887)
+ ((lambda (g892)
+ (syntax-error (g394 g885 g882 g884)))
+ g886)))
+ ($syntax-dispatch g886 '(any any))))
+ g885)))
+ (g440
+ (lambda (g1723 g1719 g1722 g1720 g1721)
+ (letrec ((g1725
+ (lambda (g1753 g1751 g1752)
+ (g1721
+ g1753
+ (g1724 g1751)
+ (map (lambda (g1754) (g393 g1754 g1720))
+ g1752))))
+ (g1724
+ (lambda (g1745)
+ (if (null? g1745)
+ '()
+ (cons ((lambda (g1746)
+ ((lambda (g1747)
+ (if g1747
+ (apply
+ (lambda (g1748)
+ (g1724 g1748))
+ g1747)
+ ((lambda (g1750)
+ (if (g256 g1750)
+ (g393 g1750 g1720)
+ (syntax-error
+ (g394 g1723
+ g1719
+ g1722)
+ '"invalid exports list in")))
+ g1746)))
+ ($syntax-dispatch
+ g1746
+ 'each-any)))
+ (car g1745))
+ (g1724 (cdr g1745)))))))
+ ((lambda (g1726)
+ ((lambda (g1727)
+ (if g1727
+ (apply
+ (lambda (g1730 g1728 g1729)
+ (g1725 '#f g1728 g1729))
+ g1727)
+ ((lambda (g1733)
+ (if (if g1733
+ (apply
+ (lambda (g1737 g1734 g1736 g1735)
+ (g256 g1734))
+ g1733)
+ '#f)
+ (apply
+ (lambda (g1741 g1738 g1740 g1739)
+ (g1725
+ (g393 g1738 g1719)
+ g1740
+ g1739))
+ g1733)
+ ((lambda (g1744)
+ (syntax-error
+ (g394 g1723 g1719 g1722)))
+ g1726)))
+ ($syntax-dispatch
+ g1726
+ '(any any each-any . each-any)))))
+ ($syntax-dispatch g1726 '(any each-any . each-any))))
+ g1723))))
+ (g439
+ (lambda (g894 g893)
+ ((lambda (g895)
+ (if g895
+ (g366 g893 g895)
+ (g429 (lambda (g896)
+ ((lambda (g897)
+ (begin (if (not g897)
+ (syntax-error
+ g896
+ '"exported identifier not visible")
+ (void))
+ (g363 g893 g896 g897)))
+ (g376 g896 '(()))))
+ (g404 g894))))
+ (g405 g894))))
+ (g438
+ (lambda (g1652 g1648 g1651 g1649 g1650)
+ (letrec ((g1653
+ (lambda (g1718 g1714 g1717 g1715 g1716)
+ (begin (g426 g1648 g1714)
+ (g1650 g1718 g1714 g1717 g1715 g1716)))))
+ ((letrec ((g1654
+ (lambda (g1659 g1655 g1658 g1656 g1657)
+ (if (null? g1659)
+ (g1653 g1659 g1655 g1658 g1656 g1657)
+ ((lambda (g1661 g1660)
+ (call-with-values
+ (lambda ()
+ (g398 g1661
+ g1660
+ '(())
+ '#f
+ g1652))
+ (lambda (g1666
+ g1662
+ g1665
+ g1663
+ g1664)
+ ((lambda (g1667)
+ (if (memv g1667 '(define-form))
+ (g442 g1665
+ g1663
+ g1664
+ (lambda (g1670
+ g1668
+ g1669)
+ ((lambda (g1672
+ g1671)
+ ((lambda (g1673)
+ (begin (g363 g1652
+ g1672
+ g1671)
+ (g424 g1649
+ g1671
+ (g231 'lexical
+ g1673))
+ (g1654
+ (cdr g1659)
+ (cons g1672
+ g1655)
+ (cons g1673
+ g1658)
+ (cons (cons g1660
+ (g393 g1668
+ g1669))
+ g1656)
+ g1657)))
+ (g451 g1672)))
+ (g393 g1670 g1669)
+ (g297))))
+ (if (memv g1667
+ '(define-syntax-form))
+ (g443 g1665
+ g1663
+ g1664
+ (lambda (g1676
+ g1674
+ g1675)
+ ((lambda (g1679
+ g1677
+ g1678)
+ (begin (g363 g1652
+ g1679
+ g1677)
+ (g424 g1649
+ g1677
+ (g231 'deferred
+ g1678))
+ (g1654
+ (cdr g1659)
+ (cons g1679
+ g1655)
+ g1658
+ g1656
+ g1657)))
+ (g393 g1676
+ g1675)
+ (g297)
+ (g432 g1674
+ (g249 g1660)
+ g1675))))
+ (if (memv g1667
+ '(module-form))
+ ((lambda (g1680)
+ ((lambda (g1681)
+ ((lambda ()
+ (g440 g1665
+ g1663
+ g1664
+ g1681
+ (lambda (g1684
+ g1682
+ g1683)
+ (g438 g1680
+ (g394 g1665
+ g1663
+ g1664)
+ (map (lambda (g1695)
+ (cons g1660
+ g1695))
+ g1683)
+ g1649
+ (lambda (g1689
+ g1685
+ g1688
+ g1686
+ g1687)
+ (begin (g425 g1648
+ (g401 g1682)
+ g1685)
+ ((lambda (g1693
+ g1690
+ g1692
+ g1691)
+ (if g1684
+ ((lambda (g1694)
+ (begin (g363 g1652
+ g1684
+ g1694)
+ (g424 g1649
+ g1694
+ (g231 'module
+ g1693))
+ (g1654
+ (cdr g1659)
+ (cons g1684
+ g1655)
+ g1690
+ g1692
+ g1691)))
+ (g297))
+ ((lambda ()
+ (begin (g439 g1693
+ g1652)
+ (g1654
+ (cdr g1659)
+ (cons g1693
+ g1655)
+ g1690
+ g1692
+ g1691))))))
+ (g408 g1682)
+ (append
+ g1688
+ g1658)
+ (append
+ g1686
+ g1656)
+ (append
+ g1657
+ g1687
+ g1689))))))))))
+ (g263 (g264 g1663)
+ (cons g1680
+ (g265 g1663)))))
+ (g304 '()
+ '()
+ '()))
+ (if (memv g1667
+ '(import-form))
+ (g441 g1665
+ g1663
+ g1664
+ (lambda (g1696)
+ ((lambda (g1697)
+ ((lambda (g1698)
+ ((lambda (g1699)
+ (if (memv g1699
+ '(module))
+ ((lambda (g1700)
+ (begin (if g1662
+ (g364 g1652
+ g1662)
+ (void))
+ (g439 g1700
+ g1652)
+ (g1654
+ (cdr g1659)
+ (cons g1700
+ g1655)
+ g1658
+ g1656
+ g1657)))
+ (cdr g1698))
+ (if (memv g1699
+ '(displaced-lexical))
+ (g250 g1696)
+ (syntax-error
+ g1696
+ '"import from unknown module"))))
+ (car g1698)))
+ (g253 g1697
+ g1649)))
+ (g377 g1696
+ '(())))))
+ (if (memv g1667
+ '(begin-form))
+ ((lambda (g1701)
+ ((lambda (g1702)
+ (if g1702
+ (apply
+ (lambda (g1704
+ g1703)
+ (g1654
+ ((letrec ((g1705
+ (lambda (g1706)
+ (if (null?
+ g1706)
+ (cdr g1659)
+ (cons (cons g1660
+ (g393 (car g1706)
+ g1663))
+ (g1705
+ (cdr g1706)))))))
+ g1705)
+ g1703)
+ g1655
+ g1658
+ g1656
+ g1657))
+ g1702)
+ (syntax-error
+ g1701)))
+ ($syntax-dispatch
+ g1701
+ '(any .
+ each-any))))
+ g1665)
+ (if (memv g1667
+ '(local-syntax-form))
+ (g445 g1662
+ g1665
+ g1660
+ g1663
+ g1664
+ (lambda (g1711
+ g1708
+ g1710
+ g1709)
+ (g1654
+ ((letrec ((g1712
+ (lambda (g1713)
+ (if (null?
+ g1713)
+ (cdr g1659)
+ (cons (cons g1708
+ (g393 (car g1713)
+ g1710))
+ (g1712
+ (cdr g1713)))))))
+ g1712)
+ g1711)
+ g1655
+ g1658
+ g1656
+ g1657)))
+ (g1653
+ (cons (cons g1660
+ (g394 g1665
+ g1663
+ g1664))
+ (cdr g1659))
+ g1655
+ g1658
+ g1656
+ g1657))))))))
+ g1666))))
+ (cdar g1659)
+ (caar g1659))))))
+ g1654)
+ g1651
+ '()
+ '()
+ '()
+ '()))))
+ (g437
+ (lambda (g901 g898 g900 g899)
+ ((lambda (g902)
+ ((lambda (g903)
+ ((lambda (g904)
+ ((lambda (g905)
+ ((lambda ()
+ (g438 g903
+ g898
+ g905
+ g902
+ (lambda (g910 g906 g909 g907 g908)
+ (begin (if (null? g910)
+ (syntax-error
+ g898
+ '"no expressions in body")
+ (void))
+ (g191 '#f
+ g909
+ (map (lambda (g912)
+ (g432 (cdr g912)
+ (car g912)
+ '(())))
+ g907)
+ (g190 '#f
+ (map (lambda (g911)
+ (g432 (cdr g911)
+ (car g911)
+ '(())))
+ (append
+ g908
+ g910))))))))))
+ (map (lambda (g913) (cons g902 (g393 g913 g904)))
+ g901)))
+ (g263 (g264 g899) (cons g903 (g265 g899)))))
+ (g304 '() '() '())))
+ (cons '("placeholder" placeholder) g900))))
+ (g436
+ (lambda (g1635 g1630 g1634 g1631 g1633 g1632)
+ (letrec ((g1636
+ (lambda (g1640 g1639)
+ (if (pair? g1640)
+ (cons (g1636 (car g1640) g1639)
+ (g1636 (cdr g1640) g1639))
+ (if (g204 g1640)
+ ((lambda (g1641)
+ ((lambda (g1643 g1642)
+ (g203 (g205 g1640)
+ (if (if (pair? g1643)
+ (eq? (car g1643)
+ '#f)
+ '#f)
+ (g263 (cdr g1643)
+ (if g1632
+ (cons g1632
+ (cdr g1642))
+ (cdr g1642)))
+ (g263 (cons g1639 g1643)
+ (if g1632
+ (cons g1632
+ (cons 'shift
+ g1642))
+ (cons 'shift
+ g1642))))))
+ (g264 g1641)
+ (g265 g1641)))
+ (g206 g1640))
+ (if (vector? g1640)
+ ((lambda (g1644)
+ ((lambda (g1645)
+ ((lambda ()
+ ((letrec ((g1646
+ (lambda (g1647)
+ (if (= g1647
+ g1644)
+ g1645
+ (begin (vector-set!
+ g1645
+ g1647
+ (g1636
+ (vector-ref
+ g1640
+ g1647)
+ g1639))
+ (g1646
+ (+ g1647
+ '1)))))))
+ g1646)
+ '0))))
+ (make-vector g1644)))
+ (vector-length g1640))
+ (if (symbol? g1640)
+ (syntax-error
+ (g394 g1630 g1631 g1633)
+ '"encountered raw symbol "
+ (format '"~s" g1640)
+ '" in output of macro")
+ g1640)))))))
+ (g1636
+ ((lambda (g1637)
+ (if (procedure? g1637)
+ (g1637
+ (lambda (g1638)
+ (begin (if (not (identifier? g1638))
+ (syntax-error
+ g1638
+ '"environment argument is not an identifier")
+ (void))
+ (g253 (g377 g1638 '(())) g1634))))
+ g1637))
+ (g1635 (g394 g1630 (g349 g1631) g1633)))
+ (string '#\m)))))
+ (g435
+ (lambda (g918 g914 g917 g915 g916)
+ ((lambda (g919)
+ ((lambda (g920)
+ (if (if g920
+ (apply
+ (lambda (g923 g921 g922) (g256 g921))
+ g920)
+ '#f)
+ (apply
+ (lambda (g926 g924 g925)
+ ((lambda (g927)
+ ((lambda (g928)
+ ((lambda (g929)
+ (if (memv g929 '(macro!))
+ ((lambda (g931 g930)
+ (g398 (g436 (g233 g928)
+ (list '#(syntax-object
+ set!
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(id
+ val)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(t)
+ #(("m" top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(b)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(n)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ id
+ val)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g931
+ g930)
+ g914
+ '(())
+ g915
+ g916)
+ g914
+ '(())
+ g915
+ g916))
+ (g393 g924 g917)
+ (g393 g925 g917))
+ (values
+ 'core
+ (lambda (g935 g932 g934 g933)
+ ((lambda (g937 g936)
+ ((lambda (g938)
+ ((lambda (g939)
+ (if (memv g939
+ '(lexical))
+ (list 'set!
+ (g233 g938)
+ g937)
+ (if (memv g939
+ '(global))
+ (list 'set!
+ (g233 g938)
+ g937)
+ (if (memv g939
+ '(displaced-lexical))
+ (syntax-error
+ (g393 g924
+ g934)
+ '"identifier out of context")
+ (syntax-error
+ (g394 g935
+ g934
+ g933))))))
+ (g232 g938)))
+ (g253 g936 g932)))
+ (g432 g925 g932 g934)
+ (g377 g924 g934)))
+ g918
+ g917
+ g915)))
+ (g232 g928)))
+ (g253 g927 g914)))
+ (g377 g924 g917)))
+ g920)
+ ((lambda (g940)
+ (syntax-error (g394 g918 g917 g915)))
+ g919)))
+ ($syntax-dispatch g919 '(any any any))))
+ g918)))
+ (g434
+ (lambda (g1622 g1618 g1621 g1619 g1620)
+ ((lambda (g1623)
+ ((lambda (g1624)
+ (if g1624
+ (apply
+ (lambda (g1626 g1625)
+ (cons g1622
+ (map (lambda (g1628)
+ (g432 g1628 g1621 g1619))
+ g1625)))
+ g1624)
+ ((lambda (g1629)
+ (syntax-error (g394 g1618 g1619 g1620)))
+ g1623)))
+ ($syntax-dispatch g1623 '(any . each-any))))
+ g1618)))
+ (g433
+ (lambda (g946 g941 g945 g942 g944 g943)
+ ((lambda (g947)
+ (if (memv g947 '(lexical))
+ g941
+ (if (memv g947 '(core))
+ (g941 g945 g942 g944 g943)
+ (if (memv g947 '(lexical-call))
+ (g434 g941 g945 g942 g944 g943)
+ (if (memv g947 '(constant))
+ (list 'quote
+ (g450 (g394 g945 g944 g943) '(())))
+ (if (memv g947 '(global))
+ g941
+ (if (memv g947 '(call))
+ (g434 (g432 (car g945) g942 g944)
+ g945
+ g942
+ g944
+ g943)
+ (if (memv g947 '(begin-form))
+ ((lambda (g948)
+ ((lambda (g949)
+ (if g949
+ (apply
+ (lambda (g952
+ g950
+ g951)
+ (g395 (cons g950
+ g951)
+ g942
+ g944
+ g943))
+ g949)
+ (syntax-error
+ g948)))
+ ($syntax-dispatch
+ g948
+ '(any any
+ .
+ each-any))))
+ g945)
+ (if (memv g947
+ '(local-syntax-form))
+ (g445 g941
+ g945
+ g942
+ g944
+ g943
+ g395)
+ (if (memv g947
+ '(eval-when-form))
+ ((lambda (g954)
+ ((lambda (g955)
+ (if g955
+ (apply
+ (lambda (g959
+ g956
+ g958
+ g957)
+ ((lambda (g960)
+ (if (memq 'eval
+ g960)
+ (g395 (cons g958
+ g957)
+ g942
+ g944
+ g943)
+ (g446)))
+ (g397 g945
+ g956
+ g944)))
+ g955)
+ (syntax-error
+ g954)))
+ ($syntax-dispatch
+ g954
+ '(any each-any
+ any
+ .
+ each-any))))
+ g945)
+ (if (memv g947
+ '(define-form
+ define-syntax-form
+ module-form
+ import-form))
+ (syntax-error
+ (g394 g945
+ g944
+ g943)
+ '"invalid context for definition")
+ (if (memv g947
+ '(syntax))
+ (syntax-error
+ (g394 g945
+ g944
+ g943)
+ '"reference to pattern variable outside syntax form")
+ (if (memv g947
+ '(displaced-lexical))
+ (g250 (g394 g945
+ g944
+ g943))
+ (syntax-error
+ (g394 g945
+ g944
+ g943)))))))))))))))
+ g946)))
+ (g432
+ (lambda (g1612 g1610 g1611)
+ (call-with-values
+ (lambda () (g398 g1612 g1610 g1611 '#f '#f))
+ (lambda (g1617 g1613 g1616 g1614 g1615)
+ (g433 g1617 g1613 g1616 g1610 g1614 g1615)))))
+ (g431
+ (lambda (g965 g963 g964)
+ ((lambda (g966)
+ (if (memv g966 '(c))
+ (if (memq 'compile g963)
+ ((lambda (g967)
+ (begin (g91 g967)
+ (if (memq 'load g963) g967 (g446))))
+ (g964))
+ (if (memq 'load g963) (g964) (g446)))
+ (if (memv g966 '(c&e))
+ ((lambda (g968) (begin (g91 g968) g968)) (g964))
+ (begin (if (memq 'eval g963) (g91 (g964)) (void))
+ (g446)))))
+ g965)))
+ (g430
+ (lambda (g1609 g1608)
+ (list '$sc-put-cte
+ (list 'quote g1609)
+ (list 'quote (g231 'do-import g1608)))))
+ (g429
+ (lambda (g970 g969)
+ ((lambda (g971)
+ ((letrec ((g972
+ (lambda (g973)
+ (if (not (= g973 g971))
+ (begin (g970 (vector-ref g969 g973))
+ (g972 (+ g973 '1)))
+ (void)))))
+ g972)
+ '0))
+ (vector-length g969))))
+ (g428
+ (lambda (g1604 g1603)
+ ((letrec ((g1605
+ (lambda (g1607 g1606)
+ (if (< g1607 '0)
+ g1606
+ (g1605
+ (- g1607 '1)
+ (cons (g1604 (vector-ref g1603 g1607))
+ g1606))))))
+ g1605)
+ (- (vector-length g1603) '1)
+ '())))
+ (g427
+ (lambda (g982 g974 g981 g975 g980 g976 g979 g977 g978)
+ (letrec ((g985
+ (lambda (g1050 g1049)
+ ((lambda (g1051)
+ (map (lambda (g1052)
+ ((lambda (g1053)
+ (if (not (g392 g1053 g1051))
+ g1052
+ (g410 (g412 g1052)
+ g1053
+ (g414 g1052)
+ (append
+ (g984 g1053)
+ (g415 g1052))
+ (g416 g1052))))
+ (g413 g1052)))
+ g1050))
+ (map (lambda (g1054)
+ (if (pair? g1054) (car g1054) g1054))
+ g1049))))
+ (g984
+ (lambda (g1043)
+ ((letrec ((g1044
+ (lambda (g1045)
+ (if (null? g1045)
+ '()
+ (if (if (pair? (car g1045))
+ (g388 g1043
+ (caar g1045))
+ '#f)
+ (g401 (cdar g1045))
+ (g1044 (cdr g1045)))))))
+ g1044)
+ g980)))
+ (g983
+ (lambda (g1048 g1046 g1047)
+ (begin (g426 g974 g1046)
+ (g425 g974 g976 g1046)
+ (g978 g1048 g1047)))))
+ ((letrec ((g986
+ (lambda (g990 g987 g989 g988)
+ (if (null? g990)
+ (g983 g989 g987 g988)
+ ((lambda (g992 g991)
+ (call-with-values
+ (lambda ()
+ (g398 g992 g991 '(()) '#f g982))
+ (lambda (g997 g993 g996 g994 g995)
+ ((lambda (g998)
+ (if (memv g998 '(define-form))
+ (g442 g996
+ g994
+ g995
+ (lambda (g1001
+ g999
+ g1000)
+ ((lambda (g1002)
+ ((lambda (g1003)
+ ((lambda (g1004)
+ ((lambda ()
+ (begin (g363 g982
+ g1002
+ g1003)
+ (g986 (cdr g990)
+ (cons g1002
+ g987)
+ (cons (g410 g997
+ g1002
+ g1003
+ g1004
+ (cons g991
+ (g393 g999
+ g1000)))
+ g989)
+ g988)))))
+ (g984 g1002)))
+ (g300)))
+ (g393 g1001
+ g1000))))
+ (if (memv g998
+ '(define-syntax-form))
+ (g443 g996
+ g994
+ g995
+ (lambda (g1007
+ g1005
+ g1006)
+ ((lambda (g1008)
+ ((lambda (g1009)
+ ((lambda (g1010)
+ ((lambda (g1011)
+ ((lambda ()
+ (begin (g424 g975
+ (g302 g1009)
+ (cons 'deferred
+ g1011))
+ (g363 g982
+ g1008
+ g1009)
+ (g986 (cdr g990)
+ (cons g1008
+ g987)
+ (cons (g410 g997
+ g1008
+ g1009
+ g1010
+ g1011)
+ g989)
+ g988)))))
+ (g432 g1005
+ (g249 g991)
+ g1006)))
+ (g984 g1008)))
+ (g300)))
+ (g393 g1007
+ g1006))))
+ (if (memv g998
+ '(module-form))
+ ((lambda (g1012)
+ ((lambda (g1013)
+ ((lambda ()
+ (g440 g996
+ g994
+ g995
+ g1013
+ (lambda (g1016
+ g1014
+ g1015)
+ (g427 g1012
+ (g394 g996
+ g994
+ g995)
+ (map (lambda (g1024)
+ (cons g991
+ g1024))
+ g1015)
+ g975
+ g1014
+ (g401 g1014)
+ g979
+ g977
+ (lambda (g1018
+ g1017)
+ ((lambda (g1019)
+ ((lambda (g1020)
+ ((lambda (g1021)
+ ((lambda ()
+ (if g1016
+ ((lambda (g1023
+ g1022)
+ (begin (g424 g975
+ (g302 g1023)
+ (g231 'module
+ g1019))
+ (g363 g982
+ g1016
+ g1023)
+ (g986 (cdr g990)
+ (cons g1016
+ g987)
+ (cons (g410 g997
+ g1016
+ g1023
+ g1022
+ g1014)
+ g1020)
+ g1021)))
+ (g300)
+ (g984 g1016))
+ ((lambda ()
+ (begin (g439 g1019
+ g982)
+ (g986 (cdr g990)
+ (cons g1019
+ g987)
+ g1020
+ g1021))))))))
+ (append
+ g988
+ g1017)))
+ (append
+ (if g1016
+ g1018
+ (g985 g1018
+ g1014))
+ g989)))
+ (g408 g1014)))))))))
+ (g263 (g264 g994)
+ (cons g1012
+ (g265 g994)))))
+ (g304 '()
+ '()
+ '()))
+ (if (memv g998
+ '(import-form))
+ (g441 g996
+ g994
+ g995
+ (lambda (g1025)
+ ((lambda (g1026)
+ ((lambda (g1027)
+ ((lambda (g1028)
+ (if (memv g1028
+ '(module))
+ ((lambda (g1029)
+ (begin (if g993
+ (g364 g982
+ g993)
+ (void))
+ (g439 g1029
+ g982)
+ (g986 (cdr g990)
+ (cons g1029
+ g987)
+ (g985 g989
+ (vector->list
+ (g404 g1029)))
+ g988)))
+ (g233 g1027))
+ (if (memv g1028
+ '(displaced-lexical))
+ (g250 g1025)
+ (syntax-error
+ g1025
+ '"import from unknown module"))))
+ (g232 g1027)))
+ (g253 g1026
+ g975)))
+ (g377 g1025
+ '(())))))
+ (if (memv g998
+ '(begin-form))
+ ((lambda (g1030)
+ ((lambda (g1031)
+ (if g1031
+ (apply
+ (lambda (g1033
+ g1032)
+ (g986 ((letrec ((g1034
+ (lambda (g1035)
+ (if (null?
+ g1035)
+ (cdr g990)
+ (cons (cons g991
+ (g393 (car g1035)
+ g994))
+ (g1034
+ (cdr g1035)))))))
+ g1034)
+ g1032)
+ g987
+ g989
+ g988))
+ g1031)
+ (syntax-error
+ g1030)))
+ ($syntax-dispatch
+ g1030
+ '(any .
+ each-any))))
+ g996)
+ (if (memv g998
+ '(local-syntax-form))
+ (g445 g993
+ g996
+ g991
+ g994
+ g995
+ (lambda (g1040
+ g1037
+ g1039
+ g1038)
+ (g986 ((letrec ((g1041
+ (lambda (g1042)
+ (if (null?
+ g1042)
+ (cdr g990)
+ (cons (cons g1037
+ (g393 (car g1042)
+ g1039))
+ (g1041
+ (cdr g1042)))))))
+ g1041)
+ g1040)
+ g987
+ g989
+ g988)))
+ (g983 g989
+ g987
+ (append
+ g988
+ (cons (cons g991
+ (g394 g996
+ g994
+ g995))
+ (cdr g990)))))))))))
+ g997))))
+ (cdar g990)
+ (caar g990))))))
+ g986)
+ g981
+ '()
+ '()
+ '()))))
+ (g426
+ (lambda (g1560 g1559)
+ (letrec ((g1564
+ (lambda (g1597 g1595 g1596)
+ ((lambda (g1598)
+ (if g1598
+ (if (g367 ((lambda (g1599)
+ ((lambda (g1600)
+ (if (g90 g1600)
+ (annotation-expression
+ g1600)
+ g1600))
+ (if (g204 g1599)
+ (g205 g1599)
+ g1599)))
+ g1597)
+ g1598
+ (if (symbol? g1597)
+ (g264 '((top)))
+ (g264 (g206 g1597))))
+ (cons g1597 g1596)
+ g1596)
+ (g1562
+ (g404 g1595)
+ (lambda (g1602 g1601)
+ (if (g1561 g1602 g1597)
+ (cons g1602 g1601)
+ g1601))
+ g1596)))
+ (g405 g1595))))
+ (g1563
+ (lambda (g1575 g1573 g1574)
+ (if (g403 g1575)
+ (if (g403 g1573)
+ (call-with-values
+ (lambda ()
+ ((lambda (g1581 g1580)
+ (if (fx> (vector-length g1581)
+ (vector-length g1580))
+ (values g1575 g1580)
+ (values g1573 g1581)))
+ (g404 g1575)
+ (g404 g1573)))
+ (lambda (g1577 g1576)
+ (g1562
+ g1576
+ (lambda (g1579 g1578)
+ (g1564 g1579 g1577 g1578))
+ g1574)))
+ (g1564 g1573 g1575 g1574))
+ (if (g403 g1573)
+ (g1564 g1575 g1573 g1574)
+ (if (g1561 g1575 g1573)
+ (cons g1575 g1574)
+ g1574)))))
+ (g1562
+ (lambda (g1590 g1588 g1589)
+ ((lambda (g1591)
+ ((letrec ((g1592
+ (lambda (g1594 g1593)
+ (if (= g1594 g1591)
+ g1593
+ (g1592
+ (+ g1594 '1)
+ (g1588
+ (vector-ref g1590 g1594)
+ g1593))))))
+ g1592)
+ '0
+ g1589))
+ (vector-length g1590))))
+ (g1561
+ (lambda (g1583 g1582)
+ (if (symbol? g1583)
+ (if (symbol? g1582)
+ (eq? g1583 g1582)
+ (if (eq? g1583
+ ((lambda (g1584)
+ ((lambda (g1585)
+ (if (g90 g1585)
+ (annotation-expression
+ g1585)
+ g1585))
+ (if (g204 g1584)
+ (g205 g1584)
+ g1584)))
+ g1582))
+ (g373 (g264 (g206 g1582))
+ (g264 '((top))))
+ '#f))
+ (if (symbol? g1582)
+ (if (eq? g1582
+ ((lambda (g1586)
+ ((lambda (g1587)
+ (if (g90 g1587)
+ (annotation-expression
+ g1587)
+ g1587))
+ (if (g204 g1586)
+ (g205 g1586)
+ g1586)))
+ g1583))
+ (g373 (g264 (g206 g1583))
+ (g264 '((top))))
+ '#f)
+ (g388 g1583 g1582))))))
+ (if (not (null? g1559))
+ ((letrec ((g1565
+ (lambda (g1568 g1566 g1567)
+ (if (null? g1566)
+ (if (not (null? g1567))
+ ((lambda (g1569)
+ (syntax-error
+ g1560
+ '"duplicate definition for "
+ (symbol->string (car g1569))
+ '" in"))
+ (syntax-object->datum g1567))
+ (void))
+ ((letrec ((g1570
+ (lambda (g1572 g1571)
+ (if (null? g1572)
+ (g1565
+ (car g1566)
+ (cdr g1566)
+ g1571)
+ (g1570
+ (cdr g1572)
+ (g1563
+ g1568
+ (car g1572)
+ g1571))))))
+ g1570)
+ g1566
+ g1567)))))
+ g1565)
+ (car g1559)
+ (cdr g1559)
+ '())
+ (void)))))
+ (g425
+ (lambda (g1057 g1055 g1056)
+ (letrec ((g1058
+ (lambda (g1065 g1064)
+ (ormap
+ (lambda (g1066)
+ (if (g403 g1066)
+ ((lambda (g1067)
+ (if g1067
+ (g367 ((lambda (g1068)
+ ((lambda (g1069)
+ (if (g90 g1069)
+ (annotation-expression
+ g1069)
+ g1069))
+ (if (g204 g1068)
+ (g205 g1068)
+ g1068)))
+ g1065)
+ g1067
+ (g264 (g206 g1065)))
+ ((lambda (g1070)
+ ((letrec ((g1071
+ (lambda (g1072)
+ (if (fx>= g1072
+ '0)
+ ((lambda (g1073)
+ (if g1073
+ g1073
+ (g1071
+ (- g1072
+ '1))))
+ (g388 g1065
+ (vector-ref
+ g1070
+ g1072)))
+ '#f))))
+ g1071)
+ (- (vector-length g1070)
+ '1)))
+ (g404 g1066))))
+ (g405 g1066))
+ (g388 g1065 g1066)))
+ g1064))))
+ ((letrec ((g1059
+ (lambda (g1061 g1060)
+ (if (null? g1061)
+ (if (not (null? g1060))
+ (syntax-error
+ g1060
+ '"missing definition for export(s)")
+ (void))
+ ((lambda (g1063 g1062)
+ (if (g1058 g1063 g1056)
+ (g1059 g1062 g1060)
+ (g1059 g1062 (cons g1063 g1060))))
+ (car g1061)
+ (cdr g1061))))))
+ g1059)
+ g1055
+ '()))))
+ (g424
+ (lambda (g1558 g1556 g1557)
+ (set-cdr! g1558 (g246 g1556 g1557 (cdr g1558)))))
+ (g423
+ (lambda (g1075 g1074)
+ (if (null? g1075)
+ '()
+ (if (g392 (car g1075) g1074)
+ (g423 (cdr g1075) g1074)
+ (cons (car g1075) (g423 (cdr g1075) g1074))))))
+ (g422
+ (lambda (g1491
+ g1482
+ g1490
+ g1483
+ g1489
+ g1484
+ g1488
+ g1485
+ g1487
+ g1486)
+ ((lambda (g1492)
+ (g427 g1490
+ (g394 g1491 g1483 g1489)
+ (map (lambda (g1555) (cons g1482 g1555)) g1486)
+ g1482
+ g1487
+ g1492
+ g1484
+ g1488
+ (lambda (g1494 g1493)
+ ((letrec ((g1495
+ (lambda (g1500
+ g1496
+ g1499
+ g1497
+ g1498)
+ (if (null? g1500)
+ ((letrec ((g1501
+ (lambda (g1504
+ g1502
+ g1503)
+ (if (null? g1504)
+ ((lambda (g1507
+ g1505
+ g1506)
+ (begin (for-each
+ (lambda (g1523)
+ (apply
+ (lambda (g1527
+ g1524
+ g1526
+ g1525)
+ (if g1524
+ (g303 g1524
+ g1526)
+ (void)))
+ g1523))
+ g1498)
+ (g190 '#f
+ (list (g431 g1484
+ g1488
+ (lambda ()
+ (if (null?
+ g1498)
+ (g446)
+ (g190 '#f
+ (map (lambda (g1518)
+ (apply
+ (lambda (g1522
+ g1519
+ g1521
+ g1520)
+ (list '$sc-put-cte
+ (list 'quote
+ g1521)
+ (if (eq? g1522
+ 'define-syntax-form)
+ g1520
+ (list 'quote
+ (g231 'module
+ (g409 g1520
+ g1521))))))
+ g1518))
+ g1498)))))
+ (g431 g1484
+ g1488
+ (lambda ()
+ ((lambda (g1508)
+ ((lambda (g1509)
+ ((lambda (g1510)
+ ((lambda ()
+ (if g1508
+ (list '$sc-put-cte
+ (list 'quote
+ (if (g373 (g264 (g206 g1485))
+ (g264 '((top))))
+ g1508
+ ((lambda (g1511)
+ (g203 g1508
+ (g263 g1511
+ (list (g304 (vector
+ g1508)
+ (vector
+ g1511)
+ (vector
+ (g101 g1508)))))))
+ (g264 (g206 g1485)))))
+ g1510)
+ ((lambda (g1512)
+ (g190 '#f
+ (list (list '$sc-put-cte
+ (list 'quote
+ g1512)
+ g1510)
+ (g430 g1512
+ g1509))))
+ (g101 'tmp))))))
+ (list 'quote
+ (g231 'module
+ (g409 g1487
+ g1509)))))
+ (g101 g1508)))
+ (if g1485
+ ((lambda (g1513)
+ ((lambda (g1514)
+ (if (g90 g1514)
+ (annotation-expression
+ g1514)
+ g1514))
+ (if (g204 g1513)
+ (g205 g1513)
+ g1513)))
+ g1485)
+ '#f))))
+ (g190 '#f
+ (map (lambda (g1517)
+ (list 'define
+ g1517
+ (g446)))
+ g1499))
+ (g191 '#f
+ g1502
+ g1505
+ (g190 '#f
+ (list (if (null?
+ g1499)
+ (g446)
+ (g190 '#f
+ (map (lambda (g1516
+ g1515)
+ (list 'set!
+ g1516
+ g1515))
+ g1499
+ g1507)))
+ (if (null?
+ g1506)
+ (g446)
+ (g190 '#f
+ g1506)))))
+ (g446)))))
+ (map (lambda (g1530)
+ (g432 (cdr g1530)
+ (car g1530)
+ '(())))
+ g1497)
+ (map (lambda (g1528)
+ (g432 (cdr g1528)
+ (car g1528)
+ '(())))
+ g1503)
+ (map (lambda (g1529)
+ (g432 (cdr g1529)
+ (car g1529)
+ '(())))
+ g1493))
+ ((lambda (g1531)
+ ((lambda (g1532)
+ (if (memv g1532
+ '(define-form))
+ ((lambda (g1533)
+ (begin (g424 g1482
+ (g302 (g414 g1531))
+ (g231 'lexical
+ g1533))
+ (g1501
+ (cdr g1504)
+ (cons g1533
+ g1502)
+ (cons (g416 g1531)
+ g1503))))
+ (g451 (g413 g1531)))
+ (if (memv g1532
+ '(define-syntax-form
+ module-form))
+ (g1501
+ (cdr g1504)
+ g1502
+ g1503)
+ (error 'sc-expand-internal
+ '"unexpected module binding type"))))
+ (g412 g1531)))
+ (car g1504))))))
+ g1501)
+ g1496
+ '()
+ '())
+ ((lambda (g1535 g1534)
+ (letrec ((g1536
+ (lambda (g1551
+ g1548
+ g1550
+ g1549)
+ ((letrec ((g1552
+ (lambda (g1554
+ g1553)
+ (if (null?
+ g1554)
+ (g1549)
+ (if (g388 (g413 (car g1554))
+ g1551)
+ (g1550
+ (car g1554)
+ (g370 (reverse
+ g1553)
+ (cdr g1554)))
+ (g1552
+ (cdr g1554)
+ (cons (car g1554)
+ g1553)))))))
+ g1552)
+ g1548
+ '()))))
+ (g1536
+ g1535
+ g1496
+ (lambda (g1538 g1537)
+ ((lambda (g1541
+ g1539
+ g1540)
+ ((lambda (g1543
+ g1542)
+ ((lambda (g1544)
+ (if (memv g1544
+ '(define-form))
+ (begin (g303 g1539
+ g1542)
+ (g1495
+ g1543
+ g1537
+ (cons g1542
+ g1499)
+ (cons (g416 g1538)
+ g1497)
+ g1498))
+ (if (memv g1544
+ '(define-syntax-form))
+ (g1495
+ g1543
+ g1537
+ g1499
+ g1497
+ (cons (list g1541
+ g1539
+ g1542
+ (g416 g1538))
+ g1498))
+ (if (memv g1544
+ '(module-form))
+ ((lambda (g1545)
+ (g1495
+ (append
+ (g401 g1545)
+ g1543)
+ g1537
+ g1499
+ g1497
+ (cons (list g1541
+ g1539
+ g1542
+ g1545)
+ g1498)))
+ (g416 g1538))
+ (error 'sc-expand-internal
+ '"unexpected module binding type")))))
+ g1541))
+ (append
+ g1540
+ g1534)
+ (g101 ((lambda (g1546)
+ ((lambda (g1547)
+ (if (g90 g1547)
+ (annotation-expression
+ g1547)
+ g1547))
+ (if (g204 g1546)
+ (g205 g1546)
+ g1546)))
+ g1535))))
+ (g412 g1538)
+ (g414 g1538)
+ (g415 g1538)))
+ (lambda ()
+ (g1495
+ g1534
+ g1496
+ g1499
+ g1497
+ g1498)))))
+ (car g1500)
+ (cdr g1500))))))
+ g1495)
+ g1492
+ g1494
+ '()
+ '()
+ '()))))
+ (g401 g1487))))
+ (g421 (lambda (g1077 g1076) (vector-set! g1077 '5 g1076)))
+ (g420 (lambda (g1481 g1480) (vector-set! g1481 '4 g1480)))
+ (g419 (lambda (g1079 g1078) (vector-set! g1079 '3 g1078)))
+ (g418 (lambda (g1479 g1478) (vector-set! g1479 '2 g1478)))
+ (g417 (lambda (g1081 g1080) (vector-set! g1081 '1 g1080)))
+ (g416 (lambda (g1477) (vector-ref g1477 '5)))
+ (g415 (lambda (g1082) (vector-ref g1082 '4)))
+ (g414 (lambda (g1476) (vector-ref g1476 '3)))
+ (g413 (lambda (g1083) (vector-ref g1083 '2)))
+ (g412 (lambda (g1475) (vector-ref g1475 '1)))
+ (g411
+ (lambda (g1084)
+ (if (vector? g1084)
+ (if (= (vector-length g1084) '6)
+ (eq? (vector-ref g1084 '0) 'module-binding)
+ '#f)
+ '#f)))
+ (g410
+ (lambda (g1474 g1470 g1473 g1471 g1472)
+ (vector 'module-binding g1474 g1470 g1473 g1471 g1472)))
+ (g409
+ (lambda (g1086 g1085)
+ (g402 (list->vector
+ (map (lambda (g1087)
+ (g369 (if (pair? g1087) (car g1087) g1087)))
+ g1086))
+ g1085)))
+ (g408
+ (lambda (g1468)
+ (g402 (list->vector
+ (map (lambda (g1469)
+ (if (pair? g1469) (car g1469) g1469))
+ g1468))
+ '#f)))
+ (g407 (lambda (g1089 g1088) (vector-set! g1089 '2 g1088)))
+ (g406 (lambda (g1467 g1466) (vector-set! g1467 '1 g1466)))
+ (g405 (lambda (g1090) (vector-ref g1090 '2)))
+ (g404 (lambda (g1465) (vector-ref g1465 '1)))
+ (g403
+ (lambda (g1091)
+ (if (vector? g1091)
+ (if (= (vector-length g1091) '3)
+ (eq? (vector-ref g1091 '0) 'interface)
+ '#f)
+ '#f)))
+ (g402
+ (lambda (g1464 g1463) (vector 'interface g1464 g1463)))
+ (g401
+ (lambda (g1092)
+ ((letrec ((g1093
+ (lambda (g1095 g1094)
+ (if (null? g1095)
+ g1094
+ (g1093
+ (cdr g1095)
+ (if (pair? (car g1095))
+ (g1093 (car g1095) g1094)
+ (cons (car g1095) g1094)))))))
+ g1093)
+ g1092
+ '())))
+ (g400
+ (lambda (g1390 g1385 g1389 g1386 g1388 g1387)
+ (call-with-values
+ (lambda () (g398 g1390 g1385 g1389 '#f g1387))
+ (lambda (g1401 g1397 g1400 g1398 g1399)
+ ((lambda (g1402)
+ (if (memv g1402 '(begin-form))
+ ((lambda (g1403)
+ ((lambda (g1404)
+ (if g1404
+ (apply (lambda (g1405) (g446)) g1404)
+ ((lambda (g1406)
+ (if g1406
+ (apply
+ (lambda (g1409 g1407 g1408)
+ (g396 (cons g1407 g1408)
+ g1385
+ g1398
+ g1399
+ g1386
+ g1388
+ g1387))
+ g1406)
+ (syntax-error g1403)))
+ ($syntax-dispatch
+ g1403
+ '(any any . each-any)))))
+ ($syntax-dispatch g1403 '(any))))
+ g1400)
+ (if (memv g1402 '(local-syntax-form))
+ (g445 g1397
+ g1400
+ g1385
+ g1398
+ g1399
+ (lambda (g1414 g1411 g1413 g1412)
+ (g396 g1414
+ g1411
+ g1413
+ g1412
+ g1386
+ g1388
+ g1387)))
+ (if (memv g1402 '(eval-when-form))
+ ((lambda (g1415)
+ ((lambda (g1416)
+ (if g1416
+ (apply
+ (lambda (g1420
+ g1417
+ g1419
+ g1418)
+ ((lambda (g1422 g1421)
+ (if (eq? g1386 'e)
+ (if (memq 'eval
+ g1422)
+ (g396 g1421
+ g1385
+ g1398
+ g1399
+ 'e
+ '(eval)
+ g1387)
+ (g446))
+ (if (memq 'load
+ g1422)
+ (if ((lambda (g1423)
+ (if g1423
+ g1423
+ (if (eq? g1386
+ 'c&e)
+ (memq 'eval
+ g1422)
+ '#f)))
+ (memq 'compile
+ g1422))
+ (g396 g1421
+ g1385
+ g1398
+ g1399
+ 'c&e
+ '(compile
+ load)
+ g1387)
+ (if (memq g1386
+ '(c c&e))
+ (g396 g1421
+ g1385
+ g1398
+ g1399
+ 'c
+ '(load)
+ g1387)
+ (g446)))
+ (if ((lambda (g1424)
+ (if g1424
+ g1424
+ (if (eq? g1386
+ 'c&e)
+ (memq 'eval
+ g1422)
+ '#f)))
+ (memq 'compile
+ g1422))
+ (begin (g91 (g396 g1421
+ g1385
+ g1398
+ g1399
+ 'e
+ '(eval)
+ g1387))
+ (g446))
+ (g446)))))
+ (g397 g1400 g1417 g1398)
+ (cons g1419 g1418)))
+ g1416)
+ (syntax-error g1415)))
+ ($syntax-dispatch
+ g1415
+ '(any each-any any . each-any))))
+ g1400)
+ (if (memv g1402 '(define-syntax-form))
+ (g443 g1400
+ g1398
+ g1399
+ (lambda (g1429 g1427 g1428)
+ ((lambda (g1430)
+ (begin ((lambda (g1435)
+ ((lambda (g1436)
+ ((lambda (g1437)
+ (if (memv g1437
+ '(displaced-lexical))
+ (g250 g1430)
+ (void)))
+ (g232 g1436)))
+ (g253 g1435
+ g1385)))
+ (g377 g1430
+ '(())))
+ (g431 g1386
+ g1388
+ (lambda ()
+ (list '$sc-put-cte
+ (list 'quote
+ ((lambda (g1431)
+ (if (g373 (g264 (g206 g1430))
+ (g264 '((top))))
+ g1431
+ ((lambda (g1432)
+ (g203 g1431
+ (g263 g1432
+ (list (g304 (vector
+ g1431)
+ (vector
+ g1432)
+ (vector
+ (g101 g1431)))))))
+ (g264 (g206 g1430)))))
+ ((lambda (g1433)
+ ((lambda (g1434)
+ (if (g90 g1434)
+ (annotation-expression
+ g1434)
+ g1434))
+ (if (g204 g1433)
+ (g205 g1433)
+ g1433)))
+ g1430)))
+ (g432 g1427
+ (g249 g1385)
+ g1428))))))
+ (g393 g1429 g1428))))
+ (if (memv g1402 '(define-form))
+ (g442 g1400
+ g1398
+ g1399
+ (lambda (g1440 g1438 g1439)
+ ((lambda (g1441)
+ (begin ((lambda (g1448)
+ ((lambda (g1449)
+ ((lambda (g1450)
+ (if (memv g1450
+ '(displaced-lexical))
+ (g250 g1441)
+ (void)))
+ (g232 g1449)))
+ (g253 g1448
+ g1385)))
+ (g377 g1441
+ '(())))
+ ((lambda (g1442)
+ ((lambda (g1443)
+ (g190 '#f
+ (list (g431 g1386
+ g1388
+ (lambda ()
+ (list '$sc-put-cte
+ (list 'quote
+ (if (eq? g1442
+ g1443)
+ g1442
+ ((lambda (g1445)
+ (g203 g1442
+ (g263 g1445
+ (list (g304 (vector
+ g1442)
+ (vector
+ g1445)
+ (vector
+ g1443))))))
+ (g264 (g206 g1441)))))
+ (list 'quote
+ (g231 'global
+ g1443)))))
+ ((lambda (g1444)
+ (begin (if (eq? g1386
+ 'c&e)
+ (g91 g1444)
+ (void))
+ g1444))
+ (list 'define
+ g1443
+ (g432 g1438
+ g1385
+ g1439))))))
+ (if (g373 (g264 (g206 g1441))
+ (g264 '((top))))
+ g1442
+ (g101 g1442))))
+ ((lambda (g1446)
+ ((lambda (g1447)
+ (if (g90 g1447)
+ (annotation-expression
+ g1447)
+ g1447))
+ (if (g204 g1446)
+ (g205 g1446)
+ g1446)))
+ g1441))))
+ (g393 g1440 g1439))))
+ (if (memv g1402 '(module-form))
+ ((lambda (g1452 g1451)
+ (g440 g1400
+ g1398
+ g1399
+ (g263 (g264 g1398)
+ (cons g1451
+ (g265 g1398)))
+ (lambda (g1455
+ g1453
+ g1454)
+ (if g1455
+ (begin ((lambda (g1456)
+ ((lambda (g1457)
+ ((lambda (g1458)
+ (if (memv g1458
+ '(displaced-lexical))
+ (g250 (g393 g1455
+ g1398))
+ (void)))
+ (g232 g1457)))
+ (g253 g1456
+ g1452)))
+ (g377 g1455
+ '(())))
+ (g422 g1400
+ g1452
+ g1451
+ g1398
+ g1399
+ g1386
+ g1388
+ g1455
+ g1453
+ g1454))
+ (g422 g1400
+ g1452
+ g1451
+ g1398
+ g1399
+ g1386
+ g1388
+ '#f
+ g1453
+ g1454)))))
+ (cons '("top-level module placeholder"
+ placeholder)
+ g1385)
+ (g304 '() '() '()))
+ (if (memv g1402
+ '(import-form))
+ (g441 g1400
+ g1398
+ g1399
+ (lambda (g1459)
+ (g431 g1386
+ g1388
+ (lambda ()
+ (begin (if g1397
+ (syntax-error
+ (g394 g1400
+ g1398
+ g1399)
+ '"not valid at top-level")
+ (void))
+ ((lambda (g1460)
+ ((lambda (g1461)
+ (if (memv g1461
+ '(module))
+ (g430 g1459
+ (g405 (g233 g1460)))
+ (if (memv g1461
+ '(displaced-lexical))
+ (g250 g1459)
+ (syntax-error
+ g1459
+ '"import from unknown module"))))
+ (g232 g1460)))
+ (g253 (g377 g1459
+ '(()))
+ '())))))))
+ ((lambda (g1462)
+ (begin (if (eq? g1386
+ 'c&e)
+ (g91 g1462)
+ (void))
+ g1462))
+ (g433 g1401
+ g1397
+ g1400
+ g1385
+ g1398
+ g1399))))))))))
+ g1401)))))
+ (g399
+ (lambda (g1099 g1096 g1098 g1097)
+ (call-with-values
+ (lambda () (g398 g1099 g1096 g1098 '#f g1097))
+ (lambda (g1104 g1100 g1103 g1101 g1102)
+ (g433 g1104 g1100 g1103 g1096 g1101 g1102)))))
+ (g398
+ (lambda (g1370 g1366 g1369 g1367 g1368)
+ (if (symbol? g1370)
+ ((lambda (g1371)
+ ((lambda (g1372)
+ ((lambda (g1373)
+ ((lambda ()
+ ((lambda (g1374)
+ (if (memv g1374 '(lexical))
+ (values
+ g1373
+ (g233 g1372)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1374 '(global))
+ (values
+ g1373
+ (g233 g1372)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1374 '(macro macro!))
+ (g398 (g436 (g233 g1372)
+ g1370
+ g1366
+ g1369
+ g1367
+ g1368)
+ g1366
+ '(())
+ '#f
+ g1368)
+ (values
+ g1373
+ (g233 g1372)
+ g1370
+ g1369
+ g1367)))))
+ g1373))))
+ (g232 g1372)))
+ (g253 g1371 g1366)))
+ (g377 g1370 g1369))
+ (if (pair? g1370)
+ ((lambda (g1375)
+ (if (g256 g1375)
+ ((lambda (g1376)
+ ((lambda (g1377)
+ ((lambda (g1378)
+ ((lambda ()
+ ((lambda (g1379)
+ (if (memv g1379 '(lexical))
+ (values
+ 'lexical-call
+ (g233 g1377)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(macro macro!))
+ (g398 (g436 (g233 g1377)
+ g1370
+ g1366
+ g1369
+ g1367
+ g1368)
+ g1366
+ '(())
+ '#f
+ g1368)
+ (if (memv g1379
+ '(core))
+ (values
+ g1378
+ (g233 g1377)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(local-syntax))
+ (values
+ 'local-syntax-form
+ (g233 g1377)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(begin))
+ (values
+ 'begin-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(eval-when))
+ (values
+ 'eval-when-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(define))
+ (values
+ 'define-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(define-syntax))
+ (values
+ 'define-syntax-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(module-key))
+ (values
+ 'module-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(import))
+ (values
+ 'import-form
+ (if (g233 g1377)
+ (g393 g1375
+ g1369)
+ '#f)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(set!))
+ (g435 g1370
+ g1366
+ g1369
+ g1367
+ g1368)
+ (values
+ 'call
+ '#f
+ g1370
+ g1369
+ g1367)))))))))))))
+ g1378))))
+ (g232 g1377)))
+ (g253 g1376 g1366)))
+ (g377 g1375 g1369))
+ (values 'call '#f g1370 g1369 g1367)))
+ (car g1370))
+ (if (g204 g1370)
+ (g398 (g205 g1370)
+ g1366
+ (g371 g1369 (g206 g1370))
+ '#f
+ g1368)
+ (if (g90 g1370)
+ (g398 (annotation-expression g1370)
+ g1366
+ g1369
+ (annotation-source g1370)
+ g1368)
+ (if ((lambda (g1380)
+ ((lambda (g1381)
+ (if g1381
+ g1381
+ ((lambda (g1382)
+ (if g1382
+ g1382
+ ((lambda (g1383)
+ (if g1383
+ g1383
+ ((lambda (g1384)
+ (if g1384
+ g1384
+ (null?
+ g1380)))
+ (char?
+ g1380))))
+ (string? g1380))))
+ (number? g1380))))
+ (boolean? g1380)))
+ g1370)
+ (values 'constant '#f g1370 g1369 g1367)
+ (values
+ 'other
+ '#f
+ g1370
+ g1369
+ g1367))))))))
+ (g397
+ (lambda (g1107 g1105 g1106)
+ ((letrec ((g1108
+ (lambda (g1110 g1109)
+ (if (null? g1110)
+ g1109
+ (g1108
+ (cdr g1110)
+ (cons ((lambda (g1111)
+ (if (g378 g1111
+ '#(syntax-object
+ compile
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(when-list
+ situations)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e when-list w)
+ #((top)
+ (top)
+ (top))
+ #("i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ 'compile
+ (if (g378 g1111
+ '#(syntax-object
+ load
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(when-list
+ situations)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ when-list
+ w)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ 'load
+ (if (g378 g1111
+ '#(syntax-object
+ eval
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(when-list
+ situations)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ when-list
+ w)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ 'eval
+ (syntax-error
+ (g393 g1111 g1106)
+ '"invalid eval-when situation")))))
+ (car g1110))
+ g1109))))))
+ g1108)
+ g1105
+ '())))
+ (g396
+ (lambda (g1358 g1352 g1357 g1353 g1356 g1354 g1355)
+ (g190 g1353
+ ((letrec ((g1359
+ (lambda (g1364 g1360 g1363 g1361 g1362)
+ (if (null? g1364)
+ '()
+ ((lambda (g1365)
+ (cons g1365
+ (g1359
+ (cdr g1364)
+ g1360
+ g1363
+ g1361
+ g1362)))
+ (g400 (car g1364)
+ g1360
+ g1363
+ g1361
+ g1362
+ g1355))))))
+ g1359)
+ g1358
+ g1352
+ g1357
+ g1356
+ g1354))))
+ (g395
+ (lambda (g1115 g1112 g1114 g1113)
+ (g190 g1113
+ ((letrec ((g1116
+ (lambda (g1119 g1117 g1118)
+ (if (null? g1119)
+ '()
+ ((lambda (g1120)
+ (cons g1120
+ (g1116
+ (cdr g1119)
+ g1117
+ g1118)))
+ (g432 (car g1119) g1117 g1118))))))
+ g1116)
+ g1115
+ g1112
+ g1114))))
+ (g394
+ (lambda (g1351 g1349 g1350)
+ (g393 (if g1350 (make-annotation g1351 g1350 '#f) g1351)
+ g1349)))
+ (g393
+ (lambda (g1122 g1121)
+ (if (if (null? (g264 g1121)) (null? (g265 g1121)) '#f)
+ g1122
+ (if (g204 g1122)
+ (g203 (g205 g1122) (g371 g1121 (g206 g1122)))
+ (if (null? g1122) g1122 (g203 g1122 g1121))))))
+ (g392
+ (lambda (g1347 g1346)
+ (if (not (null? g1346))
+ ((lambda (g1348)
+ (if g1348 g1348 (g392 g1347 (cdr g1346))))
+ (g388 g1347 (car g1346)))
+ '#f)))
+ (g391
+ (lambda (g1125 g1123 g1124)
+ ((letrec ((g1126
+ (lambda (g1128 g1127)
+ (if (null? g1128)
+ (syntax-error g1123)
+ (if (g256 (car g1128))
+ (if (g392 (car g1128) g1127)
+ (syntax-error
+ (car g1128)
+ '"duplicate "
+ g1124)
+ (g1126
+ (cdr g1128)
+ (cons (car g1128) g1127)))
+ (syntax-error
+ (car g1128)
+ '"invalid "
+ g1124))))))
+ g1126)
+ g1125
+ '())))
+ (g390
+ (lambda (g1342)
+ ((letrec ((g1343
+ (lambda (g1344)
+ ((lambda (g1345)
+ (if g1345
+ g1345
+ (if (not (g392 (car g1344) (cdr g1344)))
+ (g1343 (cdr g1344))
+ '#f)))
+ (null? g1344)))))
+ g1343)
+ g1342)))
+ (g389
+ (lambda (g1129)
+ (if ((letrec ((g1130
+ (lambda (g1131)
+ ((lambda (g1132)
+ (if g1132
+ g1132
+ (if (g256 (car g1131))
+ (g1130 (cdr g1131))
+ '#f)))
+ (null? g1131)))))
+ g1130)
+ g1129)
+ (g390 g1129)
+ '#f)))
+ (g388
+ (lambda (g1337 g1336)
+ (if (if (g204 g1337) (g204 g1336) '#f)
+ (if (eq? ((lambda (g1339)
+ (if (g90 g1339)
+ (annotation-expression g1339)
+ g1339))
+ (g205 g1337))
+ ((lambda (g1338)
+ (if (g90 g1338)
+ (annotation-expression g1338)
+ g1338))
+ (g205 g1336)))
+ (g373 (g264 (g206 g1337)) (g264 (g206 g1336)))
+ '#f)
+ (eq? ((lambda (g1341)
+ (if (g90 g1341)
+ (annotation-expression g1341)
+ g1341))
+ g1337)
+ ((lambda (g1340)
+ (if (g90 g1340)
+ (annotation-expression g1340)
+ g1340))
+ g1336)))))
+ (g378
+ (lambda (g1134 g1133)
+ (if (eq? ((lambda (g1137)
+ ((lambda (g1138)
+ (if (g90 g1138)
+ (annotation-expression g1138)
+ g1138))
+ (if (g204 g1137) (g205 g1137) g1137)))
+ g1134)
+ ((lambda (g1135)
+ ((lambda (g1136)
+ (if (g90 g1136)
+ (annotation-expression g1136)
+ g1136))
+ (if (g204 g1135) (g205 g1135) g1135)))
+ g1133))
+ (eq? (g377 g1134 '(())) (g377 g1133 '(())))
+ '#f)))
+ (g377
+ (lambda (g1333 g1332)
+ (call-with-values
+ (lambda () (g374 g1333 g1332))
+ (lambda (g1335 g1334)
+ (if (g301 g1335) (g302 g1335) g1335)))))
+ (g376
+ (lambda (g1140 g1139)
+ (call-with-values
+ (lambda () (g374 g1140 g1139))
+ (lambda (g1142 g1141) g1142))))
+ (g375
+ (lambda (g1329 g1328)
+ (call-with-values
+ (lambda () (g374 g1329 g1328))
+ (lambda (g1331 g1330)
+ (values (if (g301 g1331) (g302 g1331) g1331) g1330)))))
+ (g374
+ (lambda (g1144 g1143)
+ (letrec ((g1147
+ (lambda (g1174 g1170 g1173 g1171 g1172)
+ ((lambda (g1175)
+ ((letrec ((g1176
+ (lambda (g1177)
+ (if (= g1177 g1175)
+ (g1145
+ g1174
+ (cdr g1170)
+ g1173)
+ (if (if (eq? (vector-ref
+ g1171
+ g1177)
+ g1174)
+ (g373 g1173
+ (vector-ref
+ (g307 g1172)
+ g1177))
+ '#f)
+ (values
+ (vector-ref
+ (g308 g1172)
+ g1177)
+ g1173)
+ (g1176 (+ g1177 '1)))))))
+ g1176)
+ '0))
+ (vector-length g1171))))
+ (g1146
+ (lambda (g1159 g1155 g1158 g1156 g1157)
+ ((letrec ((g1160
+ (lambda (g1162 g1161)
+ (if (null? g1162)
+ (g1145 g1159 (cdr g1155) g1158)
+ (if (if (eq? (car g1162) g1159)
+ (g373 g1158
+ (list-ref
+ (g307 g1157)
+ g1161))
+ '#f)
+ (values
+ (list-ref
+ (g308 g1157)
+ g1161)
+ g1158)
+ (if (g357 (car g1162))
+ ((lambda (g1163)
+ (if g1163
+ ((lambda (g1164)
+ (if (symbol?
+ g1164)
+ (values
+ g1164
+ g1158)
+ (g375 g1164
+ '(()))))
+ g1163)
+ (g1160
+ (cdr g1162)
+ g1161)))
+ (g367 g1159
+ (g358 (car g1162))
+ g1158))
+ (if (if (eq? (car g1162)
+ g354)
+ (g373 g1158
+ (list-ref
+ (g307 g1157)
+ g1161))
+ '#f)
+ (values '#f g1158)
+ (g1160
+ (cdr g1162)
+ (+ g1161
+ '1)))))))))
+ g1160)
+ g1156
+ '0)))
+ (g1145
+ (lambda (g1167 g1165 g1166)
+ (if (null? g1165)
+ (values g1167 g1166)
+ ((lambda (g1168)
+ (if (eq? g1168 'shift)
+ (g1145 g1167 (cdr g1165) (cdr g1166))
+ ((lambda (g1169)
+ (if (vector? g1169)
+ (g1147
+ g1167
+ g1165
+ g1166
+ g1169
+ g1168)
+ (g1146
+ g1167
+ g1165
+ g1166
+ g1169
+ g1168)))
+ (g306 g1168))))
+ (car g1165))))))
+ (if (symbol? g1144)
+ (g1145 g1144 (g265 g1143) (g264 g1143))
+ (if (g204 g1144)
+ ((lambda (g1149 g1148)
+ ((lambda (g1150)
+ (call-with-values
+ (lambda ()
+ (g1145 g1149 (g265 g1143) g1150))
+ (lambda (g1152 g1151)
+ (if (eq? g1152 g1149)
+ (g1145 g1149 (g265 g1148) g1151)
+ (values g1152 g1151)))))
+ (g372 (g264 g1143) (g264 g1148))))
+ ((lambda (g1153)
+ (if (g90 g1153)
+ (annotation-expression g1153)
+ g1153))
+ (g205 g1144))
+ (g206 g1144))
+ (if (g90 g1144)
+ (g1145
+ ((lambda (g1154)
+ (if (g90 g1154)
+ (annotation-expression g1154)
+ g1154))
+ g1144)
+ (g265 g1143)
+ (g264 g1143))
+ (g93 'id-var-name '"invalid id" g1144)))))))
+ (g373
+ (lambda (g1326 g1325)
+ ((lambda (g1327)
+ (if g1327
+ g1327
+ (if (not (null? g1326))
+ (if (not (null? g1325))
+ (if (eq? (car g1326) (car g1325))
+ (g373 (cdr g1326) (cdr g1325))
+ '#f)
+ '#f)
+ '#f)))
+ (eq? g1326 g1325))))
+ (g372 (lambda (g1179 g1178) (g370 g1179 g1178)))
+ (g371
+ (lambda (g1322 g1321)
+ ((lambda (g1324 g1323)
+ (if (null? g1324)
+ (if (null? g1323)
+ g1321
+ (g263 (g264 g1321) (g370 g1323 (g265 g1321))))
+ (g263 (g370 g1324 (g264 g1321))
+ (g370 g1323 (g265 g1321)))))
+ (g264 g1322)
+ (g265 g1322))))
+ (g370
+ (lambda (g1181 g1180)
+ (if (null? g1180) g1181 (append g1181 g1180))))
+ (g369
+ (lambda (g1315)
+ (call-with-values
+ (lambda () (g375 g1315 '(())))
+ (lambda (g1317 g1316)
+ (begin (if (not g1317)
+ (syntax-error
+ g1315
+ '"identifier not visible for export")
+ (void))
+ ((lambda (g1318)
+ (g203 g1318
+ (g263 g1316
+ (list (g304 (vector g1318)
+ (vector g1316)
+ (vector g1317))))))
+ ((lambda (g1319)
+ ((lambda (g1320)
+ (if (g90 g1320)
+ (annotation-expression g1320)
+ g1320))
+ (if (g204 g1319) (g205 g1319) g1319)))
+ g1315)))))))
+ (g368
+ (lambda (g1184 g1182 g1183)
+ (if (null? g1184)
+ g1183
+ (g263 (g264 g1183)
+ (cons ((lambda (g1185)
+ ((lambda (g1186)
+ ((lambda (g1188 g1187)
+ (begin ((letrec ((g1189
+ (lambda (g1191
+ g1190)
+ (if (not (null?
+ g1191))
+ (call-with-values
+ (lambda ()
+ (g262 (car g1191)
+ g1183))
+ (lambda (g1193
+ g1192)
+ (begin (vector-set!
+ g1188
+ g1190
+ g1193)
+ (vector-set!
+ g1187
+ g1190
+ g1192)
+ (g1189
+ (cdr g1191)
+ (+ g1190
+ '1)))))
+ (void)))))
+ g1189)
+ g1184
+ '0)
+ (g304 g1188 g1187 g1185)))
+ (make-vector g1186)
+ (make-vector g1186)))
+ (vector-length g1185)))
+ (list->vector g1182))
+ (g265 g1183))))))
+ (g367
+ (lambda (g1310 g1308 g1309)
+ ((lambda (g1311)
+ (if g1311
+ ((letrec ((g1312
+ (lambda (g1313)
+ (if (pair? g1313)
+ ((lambda (g1314)
+ (if g1314
+ g1314
+ (g1312 (cdr g1313))))
+ (g1312 (car g1313)))
+ (if (g373 g1309 (g264 (g206 g1313)))
+ g1313
+ '#f)))))
+ g1312)
+ g1311)
+ '#f))
+ (g100 g1310 g1308))))
+ (g366
+ (lambda (g1195 g1194)
+ (g309 g1195 (cons (g356 g1194) (g306 g1195)))))
+ (g365
+ (lambda (g1307 g1306)
+ (begin (g309 g1307 (cons g354 (g306 g1307)))
+ (g310 g1307 (cons (g264 g1306) (g307 g1307))))))
+ (g364 (lambda (g1197 g1196) (g365 g1197 (g206 g1196))))
+ (g363
+ (lambda (g1304 g1302 g1303)
+ (begin (g309 g1304
+ (cons ((lambda (g1305)
+ (if (g90 g1305)
+ (annotation-expression g1305)
+ g1305))
+ (g205 g1302))
+ (g306 g1304)))
+ (g310 g1304 (cons (g264 (g206 g1302)) (g307 g1304)))
+ (g311 g1304 (cons g1303 (g308 g1304))))))
+ (g358 cdr)
+ (g357
+ (lambda (g1301)
+ (if (pair? g1301) (eq? (car g1301) g355) '#f)))
+ (g356 (lambda (g1198) (cons g355 g1198)))
+ (g355 'import-token)
+ (g354 '#f)
+ (g349
+ (lambda (g1300)
+ (g263 (cons '#f (g264 g1300)) (cons 'shift (g265 g1300)))))
+ (g311 (lambda (g1200 g1199) (vector-set! g1200 '3 g1199)))
+ (g310 (lambda (g1299 g1298) (vector-set! g1299 '2 g1298)))
+ (g309 (lambda (g1202 g1201) (vector-set! g1202 '1 g1201)))
+ (g308 (lambda (g1297) (vector-ref g1297 '3)))
+ (g307 (lambda (g1203) (vector-ref g1203 '2)))
+ (g306 (lambda (g1296) (vector-ref g1296 '1)))
+ (g305
+ (lambda (g1204)
+ (if (vector? g1204)
+ (if (= (vector-length g1204) '4)
+ (eq? (vector-ref g1204 '0) 'ribcage)
+ '#f)
+ '#f)))
+ (g304
+ (lambda (g1295 g1293 g1294)
+ (vector 'ribcage g1295 g1293 g1294)))
+ (g303 set-car!)
+ (g302 car)
+ (g301 pair?)
+ (g300 (lambda () (list (g297))))
+ (g299
+ (lambda (g1205)
+ (if (null? g1205) '() (cons (g297) (g299 (cdr g1205))))))
+ (g298
+ (lambda (g1290)
+ ((lambda (g1291)
+ (if g1291
+ g1291
+ ((lambda (g1292) (if g1292 g1292 (g301 g1290)))
+ (symbol? g1290))))
+ (string? g1290))))
+ (g297 (lambda () (string '#\i)))
+ (g265 cdr)
+ (g264 car)
+ (g263 cons)
+ (g262
+ (lambda (g1207 g1206)
+ (if (g204 g1207)
+ (values
+ ((lambda (g1208)
+ (if (g90 g1208)
+ (annotation-expression g1208)
+ g1208))
+ (g205 g1207))
+ (g372 (g264 g1206) (g264 (g206 g1207))))
+ (values
+ ((lambda (g1209)
+ (if (g90 g1209)
+ (annotation-expression g1209)
+ g1209))
+ g1207)
+ (g264 g1206)))))
+ (g256
+ (lambda (g1288)
+ (if (symbol? g1288)
+ '#t
+ (if (g204 g1288)
+ (symbol?
+ ((lambda (g1289)
+ (if (g90 g1289)
+ (annotation-expression g1289)
+ g1289))
+ (g205 g1288)))
+ (if (g90 g1288)
+ (symbol? (annotation-expression g1288))
+ '#f)))))
+ (g255
+ (lambda (g1210)
+ (if (g204 g1210)
+ (symbol?
+ ((lambda (g1211)
+ (if (g90 g1211)
+ (annotation-expression g1211)
+ g1211))
+ (g205 g1210)))
+ '#f)))
+ (g254
+ (lambda (g1287 g1285 g1286) (g98 g1285 (g231 g1287 g1286))))
+ (g253
+ (lambda (g1213 g1212)
+ (letrec ((g1214
+ (lambda (g1221 g1220)
+ (begin (g234 g1221 (g232 g1220))
+ (g235 g1221 (g233 g1220))))))
+ ((lambda (g1215)
+ ((lambda (g1216)
+ (if (memv g1216 '(deferred))
+ (begin (g1214
+ g1215
+ ((lambda (g1217)
+ ((lambda (g1218)
+ (if g1218
+ g1218
+ (syntax-error
+ g1217
+ '"invalid transformer")))
+ (g252 g1217)))
+ (g92 (g233 g1215))))
+ ((lambda (g1219) g1215) (g232 g1215)))
+ g1215))
+ (g232 g1215)))
+ (g251 g1213 g1212)))))
+ (g252
+ (lambda (g1283)
+ (if (procedure? g1283)
+ (g231 'macro g1283)
+ (if (g236 g1283)
+ ((lambda (g1284)
+ (if (memv g1284 '(core macro macro!))
+ (if (procedure? (g233 g1283)) g1283 '#f)
+ (if (memv g1284 '(module))
+ (if (g403 (g233 g1283)) g1283 '#f)
+ g1283)))
+ (g232 g1283))
+ '#f))))
+ (g251
+ (lambda (g1223 g1222)
+ ((lambda (g1224)
+ (if g1224
+ (cdr g1224)
+ (if (symbol? g1223)
+ ((lambda (g1225)
+ (if g1225 g1225 (g231 'global g1223)))
+ (g99 g1223))
+ (g231 'displaced-lexical '#f))))
+ (assq g1223 g1222))))
+ (g250
+ (lambda (g1282)
+ (syntax-error
+ g1282
+ (if (g377 g1282 '(()))
+ '"identifier out of context"
+ '"identifier not visible"))))
+ (g249
+ (lambda (g1226)
+ (if (null? g1226)
+ '()
+ ((lambda (g1227)
+ (if (eq? (cadr g1227) 'lexical)
+ (g249 (cdr g1226))
+ (cons g1227 (g249 (cdr g1226)))))
+ (car g1226)))))
+ (g248
+ (lambda (g1281 g1279 g1280)
+ (if (null? g1281)
+ g1280
+ (g248 (cdr g1281)
+ (cdr g1279)
+ (g246 (car g1281)
+ (g231 'lexical (car g1279))
+ g1280)))))
+ (g247
+ (lambda (g1230 g1228 g1229)
+ (if (null? g1230)
+ g1229
+ (g247 (cdr g1230)
+ (cdr g1228)
+ (g246 (car g1230) (car g1228) g1229)))))
+ (g246
+ (lambda (g1278 g1276 g1277)
+ (cons (cons g1278 g1276) g1277)))
+ (g236
+ (lambda (g1231)
+ (if (pair? g1231) (symbol? (car g1231)) '#f)))
+ (g235 set-cdr!)
+ (g234 set-car!)
+ (g233 cdr)
+ (g232 car)
+ (g231 (lambda (g1275 g1274) (cons g1275 g1274)))
+ (g223
+ (lambda (g1232)
+ (if (g90 g1232)
+ (annotation-source g1232)
+ (if (g204 g1232) (g223 (g205 g1232)) '#f))))
+ (g208 (lambda (g1273 g1272) (vector-set! g1273 '2 g1272)))
+ (g207 (lambda (g1234 g1233) (vector-set! g1234 '1 g1233)))
+ (g206 (lambda (g1271) (vector-ref g1271 '2)))
+ (g205 (lambda (g1235) (vector-ref g1235 '1)))
+ (g204
+ (lambda (g1270)
+ (if (vector? g1270)
+ (if (= (vector-length g1270) '3)
+ (eq? (vector-ref g1270 '0) 'syntax-object)
+ '#f)
+ '#f)))
+ (g203
+ (lambda (g1237 g1236) (vector 'syntax-object g1237 g1236)))
+ (g191
+ (lambda (g1269 g1266 g1268 g1267)
+ (if (null? g1266)
+ g1267
+ (list 'letrec (map list g1266 g1268) g1267))))
+ (g190
+ (lambda (g1239 g1238)
+ (if (null? (cdr g1238)) (car g1238) (cons 'begin g1238))))
+ (g101
+ ((lambda (g1251)
+ (letrec ((g1254
+ (lambda (g1260)
+ ((letrec ((g1261
+ (lambda (g1263 g1262)
+ (if (< g1263 g1251)
+ (list->string
+ (cons (g1253 g1263) g1262))
+ ((lambda (g1265 g1264)
+ (g1261
+ g1264
+ (cons (g1253 g1265)
+ g1262)))
+ (modulo g1263 g1251)
+ (quotient g1263 g1251))))))
+ g1261)
+ g1260
+ '())))
+ (g1253
+ (lambda (g1259) (integer->char (+ g1259 '33))))
+ (g1252 (lambda () '0)))
+ ((lambda (g1256 g1255)
+ (lambda (g1257)
+ (begin (set! g1255 (+ g1255 '1))
+ ((lambda (g1258) g1258)
+ (string->symbol
+ (string-append
+ '"#"
+ g1256
+ (g1254 g1255)))))))
+ (g1254 (g1252))
+ '-1)))
+ (- '127 '32 '2)))
+ (g100 (lambda (g1241 g1240) (getprop g1241 g1240)))
+ (g99 (lambda (g1250) (getprop g1250 '*sc-expander*)))
+ (g98 (lambda (g1243 g1242) ($sc-put-cte g1243 g1242)))
+ (g93
+ (lambda (g1249 g1247 g1248)
+ (error g1249 '"~a ~s" g1247 g1248)))
+ (g92 (lambda (g1244) (eval (list g53 g1244))))
+ (g91 (lambda (g1246) (eval (list g53 g1246))))
+ (g90 (lambda (g1245) '#f))
+ (g53 '"noexpand"))
+ (begin (set! $sc-put-cte
+ (lambda (g802 g801)
+ (letrec ((g805
+ (lambda (g831 g830)
+ ((lambda (g832)
+ (putprop g832 '*sc-expander* g830))
+ (if (symbol? g831) g831 (g377 g831 '(()))))))
+ (g804
+ (lambda (g815 g814)
+ (g429 (lambda (g816) (g803 g816 g814)) g815)))
+ (g803
+ (lambda (g818 g817)
+ (letrec ((g820
+ (lambda (g828 g827)
+ (if (pair? g827)
+ (if (g388 (car g827) g828)
+ (g820 g828 (cdr g827))
+ (g819 (car g827)
+ (g820 g828
+ (cdr g827))))
+ (if ((lambda (g829)
+ (if g829
+ g829
+ (g388 g827 g828)))
+ (not g827))
+ '#f
+ g827))))
+ (g819
+ (lambda (g826 g825)
+ (if (not g825)
+ g826
+ (cons g826 g825)))))
+ ((lambda (g821)
+ ((lambda (g822)
+ (if (if (not g822) (symbol? g818) '#f)
+ (remprop g821 g817)
+ (putprop
+ g821
+ g817
+ (g819 g818 g822))))
+ (g820 g818 (getprop g821 g817))))
+ ((lambda (g823)
+ ((lambda (g824)
+ (if (g90 g824)
+ (annotation-expression g824)
+ g824))
+ (if (g204 g823) (g205 g823) g823)))
+ g818))))))
+ ((lambda (g806)
+ ((lambda (g807)
+ (if (memv g807 '(module))
+ (begin ((lambda (g808)
+ (g804 (g404 g808) (g405 g808)))
+ (g233 g806))
+ (g805 g802 g806))
+ (if (memv g807 '(do-import))
+ ((lambda (g809)
+ ((lambda (g810)
+ ((lambda (g811)
+ (if (memv g811 '(module))
+ ((lambda (g812)
+ (begin (if (not (eq? (g405 g812)
+ g809))
+ (syntax-error
+ g802
+ '"import mismatch for module")
+ (void))
+ (g804 (g404 g812)
+ '*top*)))
+ (g233 g810))
+ (syntax-error
+ g802
+ '"import from unknown module")))
+ (g232 g810)))
+ (g253 (g377 g802 '(())) '())))
+ (g233 g801))
+ (g805 g802 g806))))
+ (g232 g806)))
+ ((lambda (g813)
+ (if g813
+ g813
+ (error 'define-syntax
+ '"invalid transformer ~s"
+ g801)))
+ (g252 g801))))))
+ (g254 'local-syntax 'letrec-syntax '#t)
+ (g254 'local-syntax 'let-syntax '#f)
+ (g254 'core
+ 'fluid-let-syntax
+ (lambda (g456 g453 g455 g454)
+ ((lambda (g457)
+ ((lambda (g458)
+ (if (if g458
+ (apply
+ (lambda (g463 g459 g462 g460 g461)
+ (g389 g459))
+ g458)
+ '#f)
+ (apply
+ (lambda (g469 g465 g468 g466 g467)
+ ((lambda (g470)
+ (begin (for-each
+ (lambda (g477 g476)
+ ((lambda (g478)
+ (if (memv g478
+ '(displaced-lexical))
+ (g250 (g393 g477
+ g455))
+ (void)))
+ (g232 (g253 g476 g453))))
+ g465
+ g470)
+ (g437 (cons g466 g467)
+ (g394 g456 g455 g454)
+ (g247 g470
+ ((lambda (g471)
+ (map (lambda (g473)
+ (g231 'deferred
+ (g432 g473
+ g471
+ g455)))
+ g468))
+ (g249 g453))
+ g453)
+ g455)))
+ (map (lambda (g480) (g377 g480 g455))
+ g465)))
+ g458)
+ ((lambda (g481)
+ (syntax-error (g394 g456 g455 g454)))
+ g457)))
+ ($syntax-dispatch
+ g457
+ '(any #(each (any any)) any . each-any))))
+ g456)))
+ (g254 'core
+ 'quote
+ (lambda (g795 g792 g794 g793)
+ ((lambda (g796)
+ ((lambda (g797)
+ (if g797
+ (apply
+ (lambda (g799 g798)
+ (list 'quote (g450 g798 g794)))
+ g797)
+ ((lambda (g800)
+ (syntax-error (g394 g795 g794 g793)))
+ g796)))
+ ($syntax-dispatch g796 '(any any))))
+ g795)))
+ (g254 'core
+ 'syntax
+ ((lambda ()
+ (letrec ((g489
+ (lambda (g584)
+ ((lambda (g585)
+ (if (memv g585 '(ref))
+ (cadr g584)
+ (if (memv g585 '(primitive))
+ (cadr g584)
+ (if (memv g585 '(quote))
+ (list 'quote (cadr g584))
+ (if (memv g585 '(lambda))
+ (list 'lambda
+ (cadr g584)
+ (g489 (caddr
+ g584)))
+ (if (memv g585 '(map))
+ ((lambda (g586)
+ (cons (if (= (length
+ g586)
+ '2)
+ 'map
+ 'map)
+ g586))
+ (map g489
+ (cdr g584)))
+ (cons (car g584)
+ (map g489
+ (cdr g584)))))))))
+ (car g584))))
+ (g488
+ (lambda (g502)
+ (if (eq? (car g502) 'list)
+ (cons 'vector (cdr g502))
+ (if (eq? (car g502) 'quote)
+ (list 'quote
+ (list->vector (cadr g502)))
+ (list 'list->vector g502)))))
+ (g487
+ (lambda (g583 g582)
+ (if (equal? g582 ''())
+ g583
+ (list 'append g583 g582))))
+ (g486
+ (lambda (g504 g503)
+ ((lambda (g505)
+ (if (memv g505 '(quote))
+ (if (eq? (car g504) 'quote)
+ (list 'quote
+ (cons (cadr g504)
+ (cadr g503)))
+ (if (eq? (cadr g503) '())
+ (list 'list g504)
+ (list 'cons g504 g503)))
+ (if (memv g505 '(list))
+ (cons 'list
+ (cons g504 (cdr g503)))
+ (list 'cons g504 g503))))
+ (car g503))))
+ (g485
+ (lambda (g575 g574)
+ ((lambda (g577 g576)
+ (if (eq? (car g575) 'ref)
+ (car g576)
+ (if (andmap
+ (lambda (g578)
+ (if (eq? (car g578) 'ref)
+ (memq (cadr g578) g577)
+ '#f))
+ (cdr g575))
+ (cons 'map
+ (cons (list 'primitive
+ (car g575))
+ (map ((lambda (g579)
+ (lambda (g580)
+ (cdr (assq (cadr g580)
+ g579))))
+ (map cons
+ g577
+ g576))
+ (cdr g575))))
+ (cons 'map
+ (cons (list 'lambda
+ g577
+ g575)
+ g576)))))
+ (map cdr g574)
+ (map (lambda (g581)
+ (list 'ref (car g581)))
+ g574))))
+ (g484
+ (lambda (g507 g506)
+ (list 'apply
+ '(primitive append)
+ (g485 g507 g506))))
+ (g483
+ (lambda (g569 g566 g568 g567)
+ (if (= g568 '0)
+ (values g566 g567)
+ (if (null? g567)
+ (syntax-error
+ g569
+ '"missing ellipsis in syntax form")
+ (call-with-values
+ (lambda ()
+ (g483 g569
+ g566
+ (- g568 '1)
+ (cdr g567)))
+ (lambda (g571 g570)
+ ((lambda (g572)
+ (if g572
+ (values
+ (cdr g572)
+ g567)
+ ((lambda (g573)
+ (values
+ g573
+ (cons (cons (cons g571
+ g573)
+ (car g567))
+ g570)))
+ (g451 'tmp))))
+ (assq g571 (car g567)))))))))
+ (g482
+ (lambda (g512 g508 g511 g509 g510)
+ (if (g256 g508)
+ ((lambda (g513)
+ ((lambda (g514)
+ (if (eq? (g232 g514) 'syntax)
+ (call-with-values
+ (lambda ()
+ ((lambda (g517)
+ (g483 g512
+ (car g517)
+ (cdr g517)
+ g509))
+ (g233 g514)))
+ (lambda (g516 g515)
+ (values
+ (list 'ref g516)
+ g515)))
+ (if (g510 g508)
+ (syntax-error
+ g512
+ '"misplaced ellipsis in syntax form")
+ (values
+ (list 'quote g508)
+ g509))))
+ (g253 g513 g511)))
+ (g377 g508 '(())))
+ ((lambda (g518)
+ ((lambda (g519)
+ (if (if g519
+ (apply
+ (lambda (g521 g520)
+ (g510 g521))
+ g519)
+ '#f)
+ (apply
+ (lambda (g523 g522)
+ (g482 g512
+ g522
+ g511
+ g509
+ (lambda (g524)
+ '#f)))
+ g519)
+ ((lambda (g525)
+ (if (if g525
+ (apply
+ (lambda (g528
+ g526
+ g527)
+ (g510 g526))
+ g525)
+ '#f)
+ (apply
+ (lambda (g531
+ g529
+ g530)
+ ((letrec ((g532
+ (lambda (g534
+ g533)
+ ((lambda (g535)
+ ((lambda (g536)
+ (if (if g536
+ (apply
+ (lambda (g538
+ g537)
+ (g510 g538))
+ g536)
+ '#f)
+ (apply
+ (lambda (g540
+ g539)
+ (g532 g539
+ (lambda (g541)
+ (call-with-values
+ (lambda ()
+ (g533 (cons '()
+ g541)))
+ (lambda (g543
+ g542)
+ (if (null?
+ (car g542))
+ (syntax-error
+ g512
+ '"extra ellipsis in syntax form")
+ (values
+ (g484 g543
+ (car g542))
+ (cdr g542))))))))
+ g536)
+ ((lambda (g544)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ g534
+ g511
+ g509
+ g510))
+ (lambda (g546
+ g545)
+ (call-with-values
+ (lambda ()
+ (g533 g545))
+ (lambda (g548
+ g547)
+ (values
+ (g487 g548
+ g546)
+ g547))))))
+ g535)))
+ ($syntax-dispatch
+ g535
+ '(any .
+ any))))
+ g534))))
+ g532)
+ g530
+ (lambda (g549)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ g531
+ g511
+ (cons '()
+ g549)
+ g510))
+ (lambda (g551
+ g550)
+ (if (null?
+ (car g550))
+ (syntax-error
+ g512
+ '"extra ellipsis in syntax form")
+ (values
+ (g485 g551
+ (car g550))
+ (cdr g550))))))))
+ g525)
+ ((lambda (g552)
+ (if g552
+ (apply
+ (lambda (g554
+ g553)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ g554
+ g511
+ g509
+ g510))
+ (lambda (g556
+ g555)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ g553
+ g511
+ g555
+ g510))
+ (lambda (g558
+ g557)
+ (values
+ (g486 g556
+ g558)
+ g557))))))
+ g552)
+ ((lambda (g559)
+ (if g559
+ (apply
+ (lambda (g561
+ g560)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ (cons g561
+ g560)
+ g511
+ g509
+ g510))
+ (lambda (g563
+ g562)
+ (values
+ (g488 g563)
+ g562))))
+ g559)
+ ((lambda (g565)
+ (values
+ (list 'quote
+ g508)
+ g509))
+ g518)))
+ ($syntax-dispatch
+ g518
+ '#(vector
+ (any .
+ each-any))))))
+ ($syntax-dispatch
+ g518
+ '(any . any)))))
+ ($syntax-dispatch
+ g518
+ '(any any . any)))))
+ ($syntax-dispatch
+ g518
+ '(any any))))
+ g508)))))
+ (lambda (g493 g490 g492 g491)
+ ((lambda (g494)
+ ((lambda (g495)
+ ((lambda (g496)
+ (if g496
+ (apply
+ (lambda (g498 g497)
+ (call-with-values
+ (lambda ()
+ (g482 g494
+ g497
+ g490
+ '()
+ g447))
+ (lambda (g500 g499)
+ (g489 g500))))
+ g496)
+ ((lambda (g501) (syntax-error g494))
+ g495)))
+ ($syntax-dispatch g495 '(any any))))
+ g494))
+ (g394 g493 g492 g491)))))))
+ (g254 'core
+ 'lambda
+ (lambda (g785 g782 g784 g783)
+ ((lambda (g786)
+ ((lambda (g787)
+ (if g787
+ (apply
+ (lambda (g789 g788)
+ (g444 (g394 g785 g784 g783)
+ g788
+ g782
+ g784
+ (lambda (g791 g790)
+ (list 'lambda g791 g790))))
+ g787)
+ (syntax-error g786)))
+ ($syntax-dispatch g786 '(any . any))))
+ g785)))
+ (g254 'core
+ 'letrec
+ (lambda (g590 g587 g589 g588)
+ ((lambda (g591)
+ ((lambda (g592)
+ (if g592
+ (apply
+ (lambda (g597 g593 g596 g594 g595)
+ ((lambda (g598)
+ (if (not (g389 g598))
+ (g391 (map (lambda (g599)
+ (g393 g599 g589))
+ g598)
+ (g394 g590 g589 g588)
+ '"bound variable")
+ ((lambda (g601 g600)
+ ((lambda (g603 g602)
+ (g191 g588
+ g600
+ (map (lambda (g606)
+ (g432 g606
+ g602
+ g603))
+ g596)
+ (g437 (cons g594 g595)
+ (g394 g590
+ g603
+ g588)
+ g602
+ g603)))
+ (g368 g598 g601 g589)
+ (g248 g601 g600 g587)))
+ (g299 g598)
+ (map g451 g598))))
+ g593))
+ g592)
+ ((lambda (g608)
+ (syntax-error (g394 g590 g589 g588)))
+ g591)))
+ ($syntax-dispatch
+ g591
+ '(any #(each (any any)) any . each-any))))
+ g590)))
+ (g254 'core
+ 'if
+ (lambda (g770 g767 g769 g768)
+ ((lambda (g771)
+ ((lambda (g772)
+ (if g772
+ (apply
+ (lambda (g775 g773 g774)
+ (list 'if
+ (g432 g773 g767 g769)
+ (g432 g774 g767 g769)
+ (g446)))
+ g772)
+ ((lambda (g776)
+ (if g776
+ (apply
+ (lambda (g780 g777 g779 g778)
+ (list 'if
+ (g432 g777 g767 g769)
+ (g432 g779 g767 g769)
+ (g432 g778 g767 g769)))
+ g776)
+ ((lambda (g781)
+ (syntax-error
+ (g394 g770 g769 g768)))
+ g771)))
+ ($syntax-dispatch
+ g771
+ '(any any any any)))))
+ ($syntax-dispatch g771 '(any any any))))
+ g770)))
+ (g254 'set! 'set! '())
+ (g254 'begin 'begin '())
+ (g254 'module-key 'module '())
+ (g254 'import 'import '#f)
+ (g254 'import 'import-only '#t)
+ (g254 'define 'define '())
+ (g254 'define-syntax 'define-syntax '())
+ (g254 'eval-when 'eval-when '())
+ (g254 'core
+ 'syntax-case
+ ((lambda ()
+ (letrec ((g612
+ (lambda (g693 g690 g692 g691)
+ (if (null? g692)
+ (list 'syntax-error g693)
+ ((lambda (g694)
+ ((lambda (g695)
+ (if g695
+ (apply
+ (lambda (g697 g696)
+ (if (if (g256 g697)
+ (if (not (g392 g697
+ g690))
+ (not (g447 g697))
+ '#f)
+ '#f)
+ ((lambda (g699 g698)
+ (list (list 'lambda
+ (list g698)
+ (g432 g696
+ (g246 g699
+ (g231 'syntax
+ (cons g698
+ '0))
+ g691)
+ (g368 (list g697)
+ (list g699)
+ '(()))))
+ g693))
+ (g297)
+ (g451 g697))
+ (g611 g693
+ g690
+ (cdr g692)
+ g691
+ g697
+ '#t
+ g696)))
+ g695)
+ ((lambda (g700)
+ (if g700
+ (apply
+ (lambda (g703
+ g701
+ g702)
+ (g611 g693
+ g690
+ (cdr g692)
+ g691
+ g703
+ g701
+ g702))
+ g700)
+ ((lambda (g704)
+ (syntax-error
+ (car g692)
+ '"invalid syntax-case clause"))
+ g694)))
+ ($syntax-dispatch
+ g694
+ '(any any any)))))
+ ($syntax-dispatch
+ g694
+ '(any any))))
+ (car g692)))))
+ (g611
+ (lambda (g635 g629 g634 g630 g633 g631 g632)
+ (call-with-values
+ (lambda () (g609 g633 g629))
+ (lambda (g637 g636)
+ (if (not (g390 (map car g636)))
+ (g391 (map car g636)
+ g633
+ '"pattern variable")
+ (if (not (andmap
+ (lambda (g638)
+ (not (g447 (car g638))))
+ g636))
+ (syntax-error
+ g633
+ '"misplaced ellipsis in syntax-case pattern")
+ ((lambda (g639)
+ (list (list 'lambda
+ (list g639)
+ (list 'if
+ ((lambda (g649)
+ ((lambda (g650)
+ (if g650
+ (apply
+ (lambda ()
+ g639)
+ g650)
+ ((lambda (g651)
+ (list 'if
+ g639
+ (g610 g636
+ g631
+ g639
+ g630)
+ (list 'quote
+ '#f)))
+ g649)))
+ ($syntax-dispatch
+ g649
+ '#(atom
+ #t))))
+ g631)
+ (g610 g636
+ g632
+ g639
+ g630)
+ (g612 g635
+ g629
+ g634
+ g630)))
+ (if (eq? g637 'any)
+ (list 'list g635)
+ (list '$syntax-dispatch
+ g635
+ (list 'quote
+ g637)))))
+ (g451 'tmp))))))))
+ (g610
+ (lambda (g683 g680 g682 g681)
+ ((lambda (g685 g684)
+ ((lambda (g687 g686)
+ (list 'apply
+ (list 'lambda
+ g686
+ (g432 g680
+ (g247 g687
+ (map (lambda (g689
+ g688)
+ (g231 'syntax
+ (cons g689
+ g688)))
+ g686
+ (map cdr
+ g683))
+ g681)
+ (g368 g685
+ g687
+ '(()))))
+ g682))
+ (g299 g685)
+ (map g451 g685)))
+ (map car g683)
+ (map cdr g683))))
+ (g609
+ (lambda (g653 g652)
+ ((letrec ((g654
+ (lambda (g657 g655 g656)
+ (if (g256 g657)
+ (if (g392 g657 g652)
+ (values
+ (vector
+ 'free-id
+ g657)
+ g656)
+ (values
+ 'any
+ (cons (cons g657
+ g655)
+ g656)))
+ ((lambda (g658)
+ ((lambda (g659)
+ (if (if g659
+ (apply
+ (lambda (g661
+ g660)
+ (g447 g660))
+ g659)
+ '#f)
+ (apply
+ (lambda (g663
+ g662)
+ (call-with-values
+ (lambda ()
+ (g654 g663
+ (+ g655
+ '1)
+ g656))
+ (lambda (g665
+ g664)
+ (values
+ (if (eq? g665
+ 'any)
+ 'each-any
+ (vector
+ 'each
+ g665))
+ g664))))
+ g659)
+ ((lambda (g666)
+ (if g666
+ (apply
+ (lambda (g668
+ g667)
+ (call-with-values
+ (lambda ()
+ (g654 g667
+ g655
+ g656))
+ (lambda (g670
+ g669)
+ (call-with-values
+ (lambda ()
+ (g654 g668
+ g655
+ g669))
+ (lambda (g672
+ g671)
+ (values
+ (cons g672
+ g670)
+ g671))))))
+ g666)
+ ((lambda (g673)
+ (if g673
+ (apply
+ (lambda ()
+ (values
+ '()
+ g656))
+ g673)
+ ((lambda (g674)
+ (if g674
+ (apply
+ (lambda (g675)
+ (call-with-values
+ (lambda ()
+ (g654 g675
+ g655
+ g656))
+ (lambda (g677
+ g676)
+ (values
+ (vector
+ 'vector
+ g677)
+ g676))))
+ g674)
+ ((lambda (g679)
+ (values
+ (vector
+ 'atom
+ (g450 g657
+ '(())))
+ g656))
+ g658)))
+ ($syntax-dispatch
+ g658
+ '#(vector
+ each-any)))))
+ ($syntax-dispatch
+ g658
+ '()))))
+ ($syntax-dispatch
+ g658
+ '(any .
+ any)))))
+ ($syntax-dispatch
+ g658
+ '(any any))))
+ g657)))))
+ g654)
+ g653
+ '0
+ '()))))
+ (lambda (g616 g613 g615 g614)
+ ((lambda (g617)
+ ((lambda (g618)
+ ((lambda (g619)
+ (if g619
+ (apply
+ (lambda (g623 g620 g622 g621)
+ (if (andmap
+ (lambda (g625)
+ (if (g256 g625)
+ (not (g447 g625))
+ '#f))
+ g622)
+ ((lambda (g626)
+ (list (list 'lambda
+ (list g626)
+ (g612 g626
+ g622
+ g621
+ g613))
+ (g432 g620
+ g613
+ '(()))))
+ (g451 'tmp))
+ (syntax-error
+ g617
+ '"invalid literals list in")))
+ g619)
+ (syntax-error g618)))
+ ($syntax-dispatch
+ g618
+ '(any any each-any . each-any))))
+ g617))
+ (g394 g616 g615 g614)))))))
+ (set! sc-expand
+ ((lambda (g763 g761 g762)
+ ((lambda (g764)
+ (lambda (g765)
+ (if (if (pair? g765) (equal? (car g765) g53) '#f)
+ (cadr g765)
+ (g400 g765 '() g764 g763 g761 g762))))
+ (g263 (g264 '((top))) (cons g762 (g265 '((top)))))))
+ 'e
+ '(eval)
+ ((lambda (g766) (begin (g366 g766 '*top*) g766))
+ (g304 '() '() '()))))
+ (set! identifier? (lambda (g705) (g255 g705)))
+ (set! datum->syntax-object
+ (lambda (g759 g758)
+ (begin ((lambda (g760)
+ (if (not (g255 g760))
+ (g93 'datum->syntax-object
+ '"invalid argument"
+ g760)
+ (void)))
+ g759)
+ (g203 g758 (g206 g759)))))
+ (set! syntax-object->datum
+ (lambda (g706) (g450 g706 '(()))))
+ (set! generate-temporaries
+ (lambda (g755)
+ (begin ((lambda (g757)
+ (if (not (list? g757))
+ (g93 'generate-temporaries
+ '"invalid argument"
+ g757)
+ (void)))
+ g755)
+ (map (lambda (g756) (g393 (gensym) '((top))))
+ g755))))
+ (set! free-identifier=?
+ (lambda (g708 g707)
+ (begin ((lambda (g710)
+ (if (not (g255 g710))
+ (g93 'free-identifier=?
+ '"invalid argument"
+ g710)
+ (void)))
+ g708)
+ ((lambda (g709)
+ (if (not (g255 g709))
+ (g93 'free-identifier=?
+ '"invalid argument"
+ g709)
+ (void)))
+ g707)
+ (g378 g708 g707))))
+ (set! bound-identifier=?
+ (lambda (g752 g751)
+ (begin ((lambda (g754)
+ (if (not (g255 g754))
+ (g93 'bound-identifier=?
+ '"invalid argument"
+ g754)
+ (void)))
+ g752)
+ ((lambda (g753)
+ (if (not (g255 g753))
+ (g93 'bound-identifier=?
+ '"invalid argument"
+ g753)
+ (void)))
+ g751)
+ (g388 g752 g751))))
+ (set! syntax-error
+ (lambda (g711 . g712)
+ (begin (for-each
+ (lambda (g714)
+ ((lambda (g715)
+ (if (not (string? g715))
+ (g93 'syntax-error
+ '"invalid argument"
+ g715)
+ (void)))
+ g714))
+ g712)
+ ((lambda (g713) (g93 '#f g713 (g450 g711 '(()))))
+ (if (null? g712)
+ '"invalid syntax"
+ (apply string-append g712))))))
+ ((lambda ()
+ (letrec ((g720
+ (lambda (g748 g745 g747 g746)
+ (if (not g746)
+ '#f
+ (if (eq? g745 'any)
+ (cons (g393 g748 g747) g746)
+ (if (g204 g748)
+ (g719 ((lambda (g749)
+ (if (g90 g749)
+ (annotation-expression
+ g749)
+ g749))
+ (g205 g748))
+ g745
+ (g371 g747 (g206 g748))
+ g746)
+ (g719 ((lambda (g750)
+ (if (g90 g750)
+ (annotation-expression
+ g750)
+ g750))
+ g748)
+ g745
+ g747
+ g746))))))
+ (g719
+ (lambda (g728 g725 g727 g726)
+ (if (null? g725)
+ (if (null? g728) g726 '#f)
+ (if (pair? g725)
+ (if (pair? g728)
+ (g720 (car g728)
+ (car g725)
+ g727
+ (g720 (cdr g728)
+ (cdr g725)
+ g727
+ g726))
+ '#f)
+ (if (eq? g725 'each-any)
+ ((lambda (g729)
+ (if g729 (cons g729 g726) '#f))
+ (g717 g728 g727))
+ ((lambda (g730)
+ (if (memv g730 '(each))
+ (if (null? g728)
+ (g718 (vector-ref
+ g725
+ '1)
+ g726)
+ ((lambda (g731)
+ (if g731
+ ((letrec ((g732
+ (lambda (g733)
+ (if (null?
+ (car g733))
+ g726
+ (cons (map car
+ g733)
+ (g732 (map cdr
+ g733)))))))
+ g732)
+ g731)
+ '#f))
+ (g716 g728
+ (vector-ref
+ g725
+ '1)
+ g727)))
+ (if (memv g730 '(free-id))
+ (if (g256 g728)
+ (if (g378 (g393 g728
+ g727)
+ (vector-ref
+ g725
+ '1))
+ g726
+ '#f)
+ '#f)
+ (if (memv g730 '(atom))
+ (if (equal?
+ (vector-ref
+ g725
+ '1)
+ (g450 g728
+ g727))
+ g726
+ '#f)
+ (if (memv g730
+ '(vector))
+ (if (vector?
+ g728)
+ (g720 (vector->list
+ g728)
+ (vector-ref
+ g725
+ '1)
+ g727
+ g726)
+ '#f)
+ (void))))))
+ (vector-ref g725 '0)))))))
+ (g718
+ (lambda (g743 g742)
+ (if (null? g743)
+ g742
+ (if (eq? g743 'any)
+ (cons '() g742)
+ (if (pair? g743)
+ (g718 (car g743)
+ (g718 (cdr g743) g742))
+ (if (eq? g743 'each-any)
+ (cons '() g742)
+ ((lambda (g744)
+ (if (memv g744 '(each))
+ (g718 (vector-ref
+ g743
+ '1)
+ g742)
+ (if (memv g744
+ '(free-id
+ atom))
+ g742
+ (if (memv g744
+ '(vector))
+ (g718 (vector-ref
+ g743
+ '1)
+ g742)
+ (void)))))
+ (vector-ref g743 '0))))))))
+ (g717
+ (lambda (g735 g734)
+ (if (g90 g735)
+ (g717 (annotation-expression g735) g734)
+ (if (pair? g735)
+ ((lambda (g736)
+ (if g736
+ (cons (g393 (car g735) g734)
+ g736)
+ '#f))
+ (g717 (cdr g735) g734))
+ (if (null? g735)
+ '()
+ (if (g204 g735)
+ (g717 (g205 g735)
+ (g371 g734 (g206 g735)))
+ '#f))))))
+ (g716
+ (lambda (g739 g737 g738)
+ (if (g90 g739)
+ (g716 (annotation-expression g739)
+ g737
+ g738)
+ (if (pair? g739)
+ ((lambda (g740)
+ (if g740
+ ((lambda (g741)
+ (if g741
+ (cons g740 g741)
+ '#f))
+ (g716 (cdr g739) g737 g738))
+ '#f))
+ (g720 (car g739) g737 g738 '()))
+ (if (null? g739)
+ '()
+ (if (g204 g739)
+ (g716 (g205 g739)
+ g737
+ (g371 g738 (g206 g739)))
+ '#f)))))))
+ (set! $syntax-dispatch
+ (lambda (g722 g721)
+ (if (eq? g721 'any)
+ (list g722)
+ (if (g204 g722)
+ (g719 ((lambda (g723)
+ (if (g90 g723)
+ (annotation-expression g723)
+ g723))
+ (g205 g722))
+ g721
+ (g206 g722)
+ '())
+ (g719 ((lambda (g724)
+ (if (g90 g724)
+ (annotation-expression g724)
+ g724))
+ g722)
+ g721
+ '(())
+ '()))))))))))))
+($sc-put-cte
+ 'with-syntax
+ (lambda (g1828)
+ ((lambda (g1829)
+ ((lambda (g1830)
+ (if g1830
+ (apply
+ (lambda (g1833 g1831 g1832)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ e1 e2)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ (cons g1831 g1832)))
+ g1830)
+ ((lambda (g1835)
+ (if g1835
+ (apply
+ (lambda (g1840 g1836 g1839 g1837 g1838)
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g1839
+ '()
+ (list g1836
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g1837 g1838)))))
+ g1835)
+ ((lambda (g1842)
+ (if g1842
+ (apply
+ (lambda (g1847 g1843 g1846 g1844 g1845)
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g1846)
+ '()
+ (list g1843
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1844 g1845)))))
+ g1842)
+ (syntax-error g1829)))
+ ($syntax-dispatch
+ g1829
+ '(any #(each (any any)) any . each-any)))))
+ ($syntax-dispatch
+ g1829
+ '(any ((any any)) any . each-any)))))
+ ($syntax-dispatch g1829 '(any () any . each-any))))
+ g1828)))
+($sc-put-cte
+ 'syntax-rules
+ (lambda (g1851)
+ ((lambda (g1852)
+ ((lambda (g1853)
+ (if g1853
+ (apply
+ (lambda (g1858 g1854 g1857 g1855 g1856)
+ (list '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ (cons '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g1854
+ (map (lambda (g1861 g1860)
+ (list (cons '#(syntax-object
+ dummy
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1860)
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1861)))
+ g1856
+ g1855))))))
+ g1853)
+ (syntax-error g1852)))
+ ($syntax-dispatch
+ g1852
+ '(any each-any . #(each ((any . any) any))))))
+ g1851)))
+($sc-put-cte
+ 'or
+ (lambda (g1862)
+ ((lambda (g1863)
+ ((lambda (g1864)
+ (if g1864
+ (apply
+ (lambda (g1865)
+ '#(syntax-object
+ #f
+ ((top)
+ #(ribcage #(_) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ g1864)
+ ((lambda (g1866)
+ (if g1866
+ (apply (lambda (g1868 g1867) g1867) g1866)
+ ((lambda (g1869)
+ (if g1869
+ (apply
+ (lambda (g1873 g1870 g1872 g1871)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1870))
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons '#(syntax-object
+ or
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1872 g1871)))))
+ g1869)
+ (syntax-error g1863)))
+ ($syntax-dispatch g1863 '(any any any . each-any)))))
+ ($syntax-dispatch g1863 '(any any)))))
+ ($syntax-dispatch g1863 '(any))))
+ g1862)))
+($sc-put-cte
+ 'and
+ (lambda (g1875)
+ ((lambda (g1876)
+ ((lambda (g1877)
+ (if g1877
+ (apply
+ (lambda (g1881 g1878 g1880 g1879)
+ (cons '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ (cons g1878
+ (cons (cons '#(syntax-object
+ and
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g1880 g1879))
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))))))
+ g1877)
+ ((lambda (g1883)
+ (if g1883
+ (apply (lambda (g1885 g1884) g1884) g1883)
+ ((lambda (g1886)
+ (if g1886
+ (apply
+ (lambda (g1887)
+ '#(syntax-object
+ #t
+ ((top)
+ #(ribcage #(_) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ g1886)
+ (syntax-error g1876)))
+ ($syntax-dispatch g1876 '(any)))))
+ ($syntax-dispatch g1876 '(any any)))))
+ ($syntax-dispatch g1876 '(any any any . each-any))))
+ g1875)))
+($sc-put-cte
+ 'let
+ (lambda (g1888)
+ ((lambda (g1889)
+ ((lambda (g1890)
+ (if (if g1890
+ (apply
+ (lambda (g1895 g1891 g1894 g1892 g1893)
+ (andmap identifier? g1891))
+ g1890)
+ '#f)
+ (apply
+ (lambda (g1901 g1897 g1900 g1898 g1899)
+ (cons (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ x v e1 e2)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g1897 (cons g1898 g1899)))
+ g1900))
+ g1890)
+ ((lambda (g1905)
+ (if (if g1905
+ (apply
+ (lambda (g1911 g1906 g1910 g1907 g1909 g1908)
+ (andmap identifier? (cons g1906 g1910)))
+ g1905)
+ '#f)
+ (apply
+ (lambda (g1918 g1913 g1917 g1914 g1916 g1915)
+ (cons (list '#(syntax-object
+ letrec
+ ((top)
+ #(ribcage
+ #(_ f x v e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (list (list g1913
+ (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_
+ f
+ x
+ v
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1917
+ (cons g1916
+ g1915)))))
+ g1913)
+ g1914))
+ g1905)
+ (syntax-error g1889)))
+ ($syntax-dispatch
+ g1889
+ '(any any #(each (any any)) any . each-any)))))
+ ($syntax-dispatch
+ g1889
+ '(any #(each (any any)) any . each-any))))
+ g1888)))
+($sc-put-cte
+ 'let*
+ (lambda (g1922)
+ ((lambda (g1923)
+ ((lambda (g1924)
+ (if (if g1924
+ (apply
+ (lambda (g1929 g1925 g1928 g1926 g1927)
+ (andmap identifier? g1925))
+ g1924)
+ '#f)
+ (apply
+ (lambda (g1935 g1931 g1934 g1932 g1933)
+ ((letrec ((g1936
+ (lambda (g1937)
+ (if (null? g1937)
+ (cons '#(syntax-object
+ let
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(bindings)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(let* x v e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons '() (cons g1932 g1933)))
+ ((lambda (g1939)
+ ((lambda (g1940)
+ (if g1940
+ (apply
+ (lambda (g1942 g1941)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(body
+ binding)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(bindings)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(let*
+ x
+ v
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list g1941)
+ g1942))
+ g1940)
+ (syntax-error g1939)))
+ ($syntax-dispatch
+ g1939
+ '(any any))))
+ (list (g1936 (cdr g1937))
+ (car g1937)))))))
+ g1936)
+ (map list g1931 g1934)))
+ g1924)
+ (syntax-error g1923)))
+ ($syntax-dispatch
+ g1923
+ '(any #(each (any any)) any . each-any))))
+ g1922)))
+($sc-put-cte
+ 'cond
+ (lambda (g1945)
+ ((lambda (g1946)
+ ((lambda (g1947)
+ (if g1947
+ (apply
+ (lambda (g1950 g1948 g1949)
+ ((letrec ((g1951
+ (lambda (g1953 g1952)
+ (if (null? g1952)
+ ((lambda (g1954)
+ ((lambda (g1955)
+ (if g1955
+ (apply
+ (lambda (g1957 g1956)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ m1 m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1957 g1956)))
+ g1955)
+ ((lambda (g1959)
+ (if g1959
+ (apply
+ (lambda (g1960)
+ (cons '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1960))
+ '((#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))))))
+ g1959)
+ ((lambda (g1961)
+ (if g1961
+ (apply
+ (lambda (g1963
+ g1962)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1963))
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1962
+ '(#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))))))
+ g1961)
+ ((lambda (g1964)
+ (if g1964
+ (apply
+ (lambda (g1967
+ g1965
+ g1966)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1967
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e0
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1965
+ g1966))))
+ g1964)
+ ((lambda (g1969)
+ (syntax-error
+ g1945))
+ g1954)))
+ ($syntax-dispatch
+ g1954
+ '(any any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ g1954
+ '(any #(free-id
+ #(syntax-object
+ =>
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ any)))))
+ ($syntax-dispatch
+ g1954
+ '(any)))))
+ ($syntax-dispatch
+ g1954
+ '(#(free-id
+ #(syntax-object
+ else
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(clause clauses)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ m1 m2)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ any
+ .
+ each-any))))
+ g1953)
+ ((lambda (g1970)
+ ((lambda (g1971)
+ ((lambda (g1972)
+ ((lambda (g1973)
+ (if g1973
+ (apply
+ (lambda (g1974)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1974))
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1971)))
+ g1973)
+ ((lambda (g1975)
+ (if g1975
+ (apply
+ (lambda (g1977
+ g1976)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1977))
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1976
+ '(#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))))
+ g1971)))
+ g1975)
+ ((lambda (g1978)
+ (if g1978
+ (apply
+ (lambda (g1981
+ g1979
+ g1980)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1981
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e0
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1979
+ g1980))
+ g1971))
+ g1978)
+ ((lambda (g1983)
+ (syntax-error
+ g1945))
+ g1972)))
+ ($syntax-dispatch
+ g1972
+ '(any any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ g1972
+ '(any #(free-id
+ #(syntax-object
+ =>
+ ((top)
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ any)))))
+ ($syntax-dispatch
+ g1972
+ '(any))))
+ g1953))
+ g1970))
+ (g1951 (car g1952) (cdr g1952)))))))
+ g1951)
+ g1948
+ g1949))
+ g1947)
+ (syntax-error g1946)))
+ ($syntax-dispatch g1946 '(any any . each-any))))
+ g1945)))
+($sc-put-cte
+ 'do
+ (lambda (g1985)
+ ((lambda (g1986)
+ ((lambda (g1987)
+ (if g1987
+ (apply
+ (lambda (g1994 g1988 g1993 g1989 g1992 g1990 g1991)
+ ((lambda (g1995)
+ ((lambda (g2005)
+ (if g2005
+ (apply
+ (lambda (g2006)
+ ((lambda (g2007)
+ ((lambda (g2009)
+ (if g2009
+ (apply
+ (lambda ()
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (map list g1988 g1993)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ not
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1992)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (append
+ g1991
+ (list (cons '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2006)))))))
+ g2009)
+ ((lambda (g2014)
+ (if g2014
+ (apply
+ (lambda (g2016 g2015)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (map list
+ g1988
+ g1993)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1992
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2016
+ g2015))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (append
+ g1991
+ (list (cons '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2006)))))))
+ g2014)
+ (syntax-error g2007)))
+ ($syntax-dispatch
+ g2007
+ '(any . each-any)))))
+ ($syntax-dispatch g2007 '())))
+ g1990))
+ g2005)
+ (syntax-error g1995)))
+ ($syntax-dispatch g1995 'each-any)))
+ (map (lambda (g1999 g1998)
+ ((lambda (g2000)
+ ((lambda (g2001)
+ (if g2001
+ (apply (lambda () g1999) g2001)
+ ((lambda (g2002)
+ (if g2002
+ (apply
+ (lambda (g2003) g2003)
+ g2002)
+ ((lambda (g2004)
+ (syntax-error g1985))
+ g2000)))
+ ($syntax-dispatch g2000 '(any)))))
+ ($syntax-dispatch g2000 '())))
+ g1998))
+ g1988
+ g1989)))
+ g1987)
+ (syntax-error g1986)))
+ ($syntax-dispatch
+ g1986
+ '(any #(each (any any . any))
+ (any . each-any)
+ .
+ each-any))))
+ g1985)))
+($sc-put-cte
+ 'quasiquote
+ (letrec ((g2030
+ (lambda (g2142)
+ (if (identifier? g2142)
+ (free-identifier=?
+ g2142
+ '#(syntax-object
+ quote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ '#f)))
+ (g2022
+ (lambda (g2036)
+ (if (identifier? g2036)
+ (free-identifier=?
+ g2036
+ '#(syntax-object
+ list
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ '#f)))
+ (g2029
+ (lambda (g2141)
+ (if (identifier? g2141)
+ (free-identifier=?
+ g2141
+ '#(syntax-object
+ cons
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ '#f)))
+ (g2023
+ (lambda (g2037)
+ ((lambda (g2038)
+ ((lambda (g2039)
+ (if g2039
+ (apply (lambda (g2040) (g2030 g2040)) g2039)
+ ((lambda (g2041) '#f) g2038)))
+ ($syntax-dispatch g2038 '(any ()))))
+ g2037)))
+ (g2028
+ (lambda (g2138 g2137)
+ ((letrec ((g2139
+ (lambda (g2140)
+ (if (null? g2140)
+ g2137
+ (g2024 (car g2140) (g2139 (cdr g2140)))))))
+ g2139)
+ g2138)))
+ (g2024
+ (lambda (g2043 g2042)
+ ((lambda (g2044)
+ ((lambda (g2045)
+ (if g2045
+ (apply
+ (lambda (g2047 g2046)
+ ((lambda (g2048)
+ ((lambda (g2049)
+ (if (if g2049
+ (apply
+ (lambda (g2051 g2050)
+ (g2030 g2051))
+ g2049)
+ '#f)
+ (apply
+ (lambda (g2053 g2052)
+ ((lambda (g2054)
+ ((lambda (g2055)
+ (if (if g2055
+ (apply
+ (lambda (g2057
+ g2056)
+ (g2030 g2057))
+ g2055)
+ '#f)
+ (apply
+ (lambda (g2059 g2058)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(quote?
+ dx)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quote?
+ dy)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(x y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2058
+ g2052)))
+ g2055)
+ ((lambda (g2060)
+ (if (null? g2052)
+ (list '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(quote?
+ dy)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2047)
+ (list '#(syntax-object
+ cons
+ ((top)
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(quote?
+ dy)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2047
+ g2046)))
+ g2054)))
+ ($syntax-dispatch
+ g2054
+ '(any any))))
+ g2047))
+ g2049)
+ ((lambda (g2061)
+ (if (if g2061
+ (apply
+ (lambda (g2063 g2062)
+ (g2022 g2063))
+ g2061)
+ '#f)
+ (apply
+ (lambda (g2065 g2064)
+ (cons '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(listp stuff)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2047 g2064)))
+ g2061)
+ ((lambda (g2066)
+ (list '#(syntax-object
+ cons
+ ((top)
+ #(ribcage
+ #(else)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2047
+ g2046))
+ g2048)))
+ ($syntax-dispatch
+ g2048
+ '(any . any)))))
+ ($syntax-dispatch g2048 '(any any))))
+ g2046))
+ g2045)
+ (syntax-error g2044)))
+ ($syntax-dispatch g2044 '(any any))))
+ (list g2043 g2042))))
+ (g2027
+ (lambda (g2129 g2128)
+ ((lambda (g2130)
+ (if (null? g2130)
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(ls) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x y) #((top) (top)) #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ ())
+ (if (null? (cdr g2130))
+ (car g2130)
+ ((lambda (g2131)
+ ((lambda (g2132)
+ (if g2132
+ (apply
+ (lambda (g2133)
+ (cons '#(syntax-object
+ append
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(ls)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2133))
+ g2132)
+ (syntax-error g2131)))
+ ($syntax-dispatch g2131 'each-any)))
+ g2130))))
+ ((letrec ((g2135
+ (lambda (g2136)
+ (if (null? g2136)
+ (if (g2023 g2128) '() (list g2128))
+ (if (g2023 (car g2136))
+ (g2135 (cdr g2136))
+ (cons (car g2136)
+ (g2135 (cdr g2136))))))))
+ g2135)
+ g2129))))
+ (g2025
+ (lambda (g2067)
+ ((lambda (g2068)
+ ((lambda (g2069)
+ ((lambda (g2070)
+ ((lambda (g2071)
+ (if (if g2071
+ (apply
+ (lambda (g2073 g2072) (g2030 g2073))
+ g2071)
+ '#f)
+ (apply
+ (lambda (g2075 g2074)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(quote? x)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(pat-x)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (list->vector g2074)))
+ g2071)
+ ((lambda (g2077)
+ ((letrec ((g2078
+ (lambda (g2080 g2079)
+ ((lambda (g2081)
+ ((lambda (g2082)
+ (if (if g2082
+ (apply
+ (lambda (g2084
+ g2083)
+ (g2030
+ g2084))
+ g2082)
+ '#f)
+ (apply
+ (lambda (g2086
+ g2085)
+ (g2079
+ (map (lambda (g2087)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(quote?
+ x)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ k)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(pat-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2087))
+ g2085)))
+ g2082)
+ ((lambda (g2088)
+ (if (if g2088
+ (apply
+ (lambda (g2090
+ g2089)
+ (g2022
+ g2090))
+ g2088)
+ '#f)
+ (apply
+ (lambda (g2092
+ g2091)
+ (g2079
+ g2091))
+ g2088)
+ ((lambda (g2094)
+ (if (if g2094
+ (apply
+ (lambda (g2097
+ g2095
+ g2096)
+ (g2029
+ g2097))
+ g2094)
+ '#f)
+ (apply
+ (lambda (g2100
+ g2098
+ g2099)
+ (g2078
+ g2099
+ (lambda (g2101)
+ (g2079
+ (cons g2098
+ g2101)))))
+ g2094)
+ ((lambda (g2102)
+ (list '#(syntax-object
+ list->vector
+ ((top)
+ #(ribcage
+ #(else)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ k)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(pat-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2069))
+ g2081)))
+ ($syntax-dispatch
+ g2081
+ '(any any
+ any)))))
+ ($syntax-dispatch
+ g2081
+ '(any .
+ each-any)))))
+ ($syntax-dispatch
+ g2081
+ '(any each-any))))
+ g2080))))
+ g2078)
+ g2067
+ (lambda (g2103)
+ (cons '#(syntax-object
+ vector
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(ls)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(pat-x)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2103))))
+ g2070)))
+ ($syntax-dispatch g2070 '(any each-any))))
+ g2069))
+ g2068))
+ g2067)))
+ (g2026
+ (lambda (g2105 g2104)
+ ((lambda (g2106)
+ ((lambda (g2107)
+ (if g2107
+ (apply
+ (lambda (g2108)
+ (if (= g2104 '0)
+ g2108
+ (g2024
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage #(p) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage #(p) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (g2026 (list g2108) (- g2104 '1)))))
+ g2107)
+ ((lambda (g2109)
+ (if g2109
+ (apply
+ (lambda (g2111 g2110)
+ (if (= g2104 '0)
+ (g2028 g2111 (g2026 g2110 g2104))
+ (g2024
+ (g2024
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p q)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage
+ #(p q)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (g2026 g2111 (- g2104 '1)))
+ (g2026 g2110 g2104))))
+ g2109)
+ ((lambda (g2114)
+ (if g2114
+ (apply
+ (lambda (g2116 g2115)
+ (if (= g2104 '0)
+ (g2027
+ g2116
+ (g2026 g2115 g2104))
+ (g2024
+ (g2024
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p q)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ unquote-splicing
+ ((top)
+ #(ribcage
+ #(p q)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ (g2026
+ g2116
+ (- g2104 '1)))
+ (g2026 g2115 g2104))))
+ g2114)
+ ((lambda (g2119)
+ (if g2119
+ (apply
+ (lambda (g2120)
+ (g2024
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ (g2026
+ (list g2120)
+ (+ g2104 '1))))
+ g2119)
+ ((lambda (g2121)
+ (if g2121
+ (apply
+ (lambda (g2123 g2122)
+ (g2024
+ (g2026
+ g2123
+ g2104)
+ (g2026
+ g2122
+ g2104)))
+ g2121)
+ ((lambda (g2124)
+ (if g2124
+ (apply
+ (lambda (g2125)
+ (g2025
+ (g2026
+ g2125
+ g2104)))
+ g2124)
+ ((lambda (g2127)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(p
+ lev)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2127))
+ g2106)))
+ ($syntax-dispatch
+ g2106
+ '#(vector
+ each-any)))))
+ ($syntax-dispatch
+ g2106
+ '(any . any)))))
+ ($syntax-dispatch
+ g2106
+ '(#(free-id
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ any)))))
+ ($syntax-dispatch
+ g2106
+ '((#(free-id
+ #(syntax-object
+ unquote-splicing
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ .
+ each-any)
+ .
+ any)))))
+ ($syntax-dispatch
+ g2106
+ '((#(free-id
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ .
+ each-any)
+ .
+ any)))))
+ ($syntax-dispatch
+ g2106
+ '(#(free-id
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage #(p lev) #((top) (top)) #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ any))))
+ g2105))))
+ (lambda (g2031)
+ ((lambda (g2032)
+ ((lambda (g2033)
+ (if g2033
+ (apply (lambda (g2035 g2034) (g2026 g2034 '0)) g2033)
+ (syntax-error g2032)))
+ ($syntax-dispatch g2032 '(any any))))
+ g2031))))
+($sc-put-cte
+ 'include
+ (lambda (g2143)
+ (letrec ((g2144
+ (lambda (g2155 g2154)
+ ((lambda (g2156)
+ ((letrec ((g2157
+ (lambda ()
+ ((lambda (g2158)
+ (if (eof-object? g2158)
+ (begin (close-input-port g2156) '())
+ (cons (datum->syntax-object
+ g2154
+ g2158)
+ (g2157))))
+ (read g2156)))))
+ g2157)))
+ (open-input-file g2155)))))
+ ((lambda (g2145)
+ ((lambda (g2146)
+ (if g2146
+ (apply
+ (lambda (g2148 g2147)
+ ((lambda (g2149)
+ ((lambda (g2150)
+ ((lambda (g2151)
+ (if g2151
+ (apply
+ (lambda (g2152)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(exp)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(fn)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(k filename)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ (read-file)
+ ((top))
+ ("i"))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2152))
+ g2151)
+ (syntax-error g2150)))
+ ($syntax-dispatch g2150 'each-any)))
+ (g2144 g2149 g2148)))
+ (syntax-object->datum g2147)))
+ g2146)
+ (syntax-error g2145)))
+ ($syntax-dispatch g2145 '(any any))))
+ g2143))))
+($sc-put-cte
+ 'unquote
+ (lambda (g2159)
+ ((lambda (g2160)
+ ((lambda (g2161)
+ (if g2161
+ (apply
+ (lambda (g2163 g2162)
+ (syntax-error
+ g2159
+ '"expression not valid outside of quasiquote"))
+ g2161)
+ (syntax-error g2160)))
+ ($syntax-dispatch g2160 '(any . each-any))))
+ g2159)))
+($sc-put-cte
+ 'unquote-splicing
+ (lambda (g2164)
+ ((lambda (g2165)
+ ((lambda (g2166)
+ (if g2166
+ (apply
+ (lambda (g2168 g2167)
+ (syntax-error
+ g2164
+ '"expression not valid outside of quasiquote"))
+ g2166)
+ (syntax-error g2165)))
+ ($syntax-dispatch g2165 '(any . each-any))))
+ g2164)))
+($sc-put-cte
+ 'case
+ (lambda (g2169)
+ ((lambda (g2170)
+ ((lambda (g2171)
+ (if g2171
+ (apply
+ (lambda (g2175 g2172 g2174 g2173)
+ ((lambda (g2176)
+ ((lambda (g2203)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage #(body) #((top)) #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(body)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2172))
+ g2203))
+ g2176))
+ ((letrec ((g2177
+ (lambda (g2179 g2178)
+ (if (null? g2178)
+ ((lambda (g2180)
+ ((lambda (g2181)
+ (if g2181
+ (apply
+ (lambda (g2183 g2182)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2183
+ g2182)))
+ g2181)
+ ((lambda (g2185)
+ (if g2185
+ (apply
+ (lambda (g2188
+ g2186
+ g2187)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ memv
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2188))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2186
+ g2187))))
+ g2185)
+ ((lambda (g2191)
+ (syntax-error
+ g2169))
+ g2180)))
+ ($syntax-dispatch
+ g2180
+ '(each-any
+ any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ g2180
+ '(#(free-id
+ #(syntax-object
+ else
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(clause clauses)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ any
+ .
+ each-any))))
+ g2179)
+ ((lambda (g2192)
+ ((lambda (g2193)
+ ((lambda (g2194)
+ ((lambda (g2195)
+ (if g2195
+ (apply
+ (lambda (g2198
+ g2196
+ g2197)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ memv
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2198))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2196
+ g2197))
+ g2193))
+ g2195)
+ ((lambda (g2201)
+ (syntax-error
+ g2169))
+ g2194)))
+ ($syntax-dispatch
+ g2194
+ '(each-any
+ any
+ .
+ each-any))))
+ g2179))
+ g2192))
+ (g2177 (car g2178) (cdr g2178)))))))
+ g2177)
+ g2174
+ g2173)))
+ g2171)
+ (syntax-error g2170)))
+ ($syntax-dispatch g2170 '(any any any . each-any))))
+ g2169)))
+($sc-put-cte
+ 'identifier-syntax
+ (lambda (g2204)
+ ((lambda (g2205)
+ ((lambda (g2206)
+ (if g2206
+ (apply
+ (lambda (g2208 g2207)
+ (list '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage #(_ e) #((top) (top)) #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage #(_ e) #((top) (top)) #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '()
+ (list '#(syntax-object
+ id
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '(#(syntax-object
+ identifier?
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ id
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2207))
+ (list (cons g2208
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g2207
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))))))))
+ g2206)
+ ((lambda (g2209)
+ (if (if g2209
+ (apply
+ (lambda (g2215 g2210 g2214 g2211 g2213 g2212)
+ (if (identifier? g2210)
+ (identifier? g2211)
+ '#f))
+ g2209)
+ '#f)
+ (apply
+ (lambda (g2221 g2216 g2220 g2217 g2219 g2218)
+ (list '#(syntax-object
+ cons
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top) (top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ macro!
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (list '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '(#(syntax-object
+ set!
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (list (list '#(syntax-object
+ set!
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2217
+ g2219)
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2218))
+ (list (cons g2216
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2220
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))))))
+ (list g2216
+ (list '#(syntax-object
+ identifier?
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2216))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2220))))))
+ g2209)
+ (syntax-error g2205)))
+ ($syntax-dispatch
+ g2205
+ '(any (any any)
+ ((#(free-id
+ #(syntax-object
+ set!
+ ((top)
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ any
+ any)
+ any))))))
+ ($syntax-dispatch g2205 '(any any))))
+ g2204)))
--- /dev/null
+;;; Portable implementation of syntax-case
+;;; Extracted from Chez Scheme Version 6.3
+;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+
+;;; Copyright (c) 1992-2000 Cadence Research Systems
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright notice in full. This software
+;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
+;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
+;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
+;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
+;;; NATURE WHATSOEVER.
+
+;;; Before attempting to port this code to a new implementation of
+;;; Scheme, please read the notes below carefully.
+
+;;; This file defines the syntax-case expander, sc-expand, and a set
+;;; of associated syntactic forms and procedures. Of these, the
+;;; following are documented in The Scheme Programming Language,
+;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996), which can be
+;;; found online at http://www.scheme.com. Most are also documented
+;;; in the R4RS and draft R5RS.
+;;;
+;;; bound-identifier=?
+;;; datum->syntax-object
+;;; define-syntax
+;;; fluid-let-syntax
+;;; free-identifier=?
+;;; generate-temporaries
+;;; identifier?
+;;; identifier-syntax
+;;; let-syntax
+;;; letrec-syntax
+;;; syntax
+;;; syntax-case
+;;; syntax-object->datum
+;;; syntax-rules
+;;; with-syntax
+;;;
+;;; All standard Scheme syntactic forms are supported by the expander
+;;; or syntactic abstractions defined in this file. Only the R4RS
+;;; delay is omitted, since its expansion is implementation-dependent.
+
+;;; Also defined are three forms that support modules: module, import,
+;;; and import-only. These are documented in the Chez Scheme User's
+;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
+;;; also be found online at http://www.scheme.com. They are described
+;;; briefly here as well.
+;;;
+;;; Both are definitions and may appear where and only where other
+;;; definitions may appear. modules may be named:
+;;;
+;;; (module id (ex ...) defn ... init ...)
+;;;
+;;; or anonymous:
+;;;
+;;; (module (ex ...) defn ... init ...)
+;;;
+;;; The latter form is semantically equivalent to:
+;;;
+;;; (module T (ex ...) defn ... init ...)
+;;; (import T)
+;;;
+;;; where T is a fresh identifier.
+;;;
+;;; In either form, each of the exports in (ex ...) is either an
+;;; identifier or of the form (id ex ...). In the former case, the
+;;; single identifier ex is exported. In the latter, the identifier
+;;; id is exported and the exports ex ... are "implicitly" exported.
+;;; This listing of implicit exports is useful only when id is a
+;;; keyword bound to a transformer that expands into references to
+;;; the listed implicit exports. In the present implementation,
+;;; listing of implicit exports is necessary only for top-level
+;;; modules and allows the implementation to avoid placing all
+;;; identifiers into the top-level environment where subsequent passes
+;;; of the compiler will be unable to deal effectively with them.
+;;;
+;;; Named modules may be referenced in import statements, which
+;;; always take one of the forms:
+;;;
+;;; (import id)
+;;; (import-only id)
+;;;
+;;; id must name a module. Each exported identifier becomes visible
+;;; within the scope of the import form. In the case of import-only,
+;;; all other identifiers become invisible in the scope of the
+;;; import-only form, except for those established by definitions
+;;; that appear textually after the import-only form.
+
+;;; The remaining exports are listed below. sc-expand, eval-when, and
+;;; syntax-error are described in the Chez Scheme User's Guide.
+;;;
+;;; (sc-expand datum)
+;;; if datum represents a valid expression, sc-expand returns an
+;;; expanded version of datum in a core language that includes no
+;;; syntactic abstractions. The core language includes begin,
+;;; define, if, lambda, letrec, quote, and set!.
+;;; (eval-when situations expr ...)
+;;; conditionally evaluates expr ... at compile-time or run-time
+;;; depending upon situations
+;;; (syntax-error object message)
+;;; used to report errors found during expansion
+;;; ($syntax-dispatch e p)
+;;; used by expanded code to handle syntax-case matching
+;;; ($sc-put-cte symbol val)
+;;; used to establish top-level compile-time (expand-time) bindings.
+
+;;; The following nonstandard procedures must be provided by the
+;;; implementation for this code to run.
+;;;
+;;; (void)
+;;; returns the implementation's cannonical "unspecified value". The
+;;; following usually works:
+;;;
+;;; (define void (lambda () (if #f #f))).
+;;;
+;;; (andmap proc list1 list2 ...)
+;;; returns true if proc returns true when applied to each element of list1
+;;; along with the corresponding elements of list2 .... The following
+;;; definition works but does no error checking:
+;;;
+;;; (define andmap
+;;; (lambda (f first . rest)
+;;; (or (null? first)
+;;; (if (null? rest)
+;;; (let andmap ((first first))
+;;; (let ((x (car first)) (first (cdr first)))
+;;; (if (null? first)
+;;; (f x)
+;;; (and (f x) (andmap first)))))
+;;; (let andmap ((first first) (rest rest))
+;;; (let ((x (car first))
+;;; (xr (map car rest))
+;;; (first (cdr first))
+;;; (rest (map cdr rest)))
+;;; (if (null? first)
+;;; (apply f (cons x xr))
+;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
+;;;
+;;; (ormap proc list1)
+;;; returns the first non-false return result of proc applied to
+;;; the elements of list1 or false if none. The following definition
+;;; works but does no error checking:
+;;;
+;;; (define ormap
+;;; (lambda (proc list1)
+;;; (and (not (null? list1))
+;;; (or (proc (car list1)) (ormap proc (cdr list1))))))
+;;;
+;;; The following nonstandard procedures must also be provided by the
+;;; implementation for this code to run using the standard portable
+;;; hooks and output constructors. They are not used by expanded code,
+;;; and so need be present only at expansion time.
+;;;
+;;; (eval x)
+;;; where x is always in the form ("noexpand" expr).
+;;; returns the value of expr. the "noexpand" flag is used to tell the
+;;; evaluator/expander that no expansion is necessary, since expr has
+;;; already been fully expanded to core forms.
+;;;
+;;; eval will not be invoked during the loading of psyntax.pp. After
+;;; psyntax.pp has been loaded, the expansion of any macro definition,
+;;; whether local or global, results in a call to eval. If, however,
+;;; sc-expand has already been registered as the expander to be used
+;;; by eval, and eval accepts one argument, nothing special must be done
+;;; to support the "noexpand" flag, since it is handled by sc-expand.
+;;;
+;;; (error who format-string why what)
+;;; where who is either a symbol or #f, format-string is always "~a ~s",
+;;; why is always a string, and what may be any object. error should
+;;; signal an error with a message something like
+;;;
+;;; "error in <who>: <why> <what>"
+;;;
+;;; (gensym)
+;;; returns a unique symbol each time it's called. In Chez Scheme, gensym
+;;; returns a symbol with a "globally" unique name so that gensyms that
+;;; end up in the object code of separately compiled files cannot conflict.
+;;; This is necessary only if you intend to support compiled files.
+;;;
+;;; (putprop symbol key value)
+;;; (getprop symbol key)
+;;; (remprop symbol key)
+;;; key is always a symbol; value may be any object. putprop should
+;;; associate the given value with the given symbol and key in some way
+;;; that it can be retrieved later with getprop. getprop should return
+;;; #f if no value is associated with the given symbol and key. remprop
+;;; should remove the association between the given symbol and key.
+
+;;; When porting to a new Scheme implementation, you should define the
+;;; procedures listed above, load the expanded version of psyntax.ss
+;;; (psyntax.pp, which should be available whereever you found
+;;; psyntax.ss), and register sc-expand as the current expander (how
+;;; you do this depends upon your implementation of Scheme). You may
+;;; change the hooks and constructors defined toward the beginning of
+;;; the code below, but to avoid bootstrapping problems, do so only
+;;; after you have a working version of the expander.
+
+;;; Chez Scheme allows the syntactic form (syntax <template>) to be
+;;; abbreviated to #'<template>, just as (quote <datum>) may be
+;;; abbreviated to '<datum>. The #' syntax makes programs written
+;;; using syntax-case shorter and more readable and draws out the
+;;; intuitive connection between syntax and quote. If you have access
+;;; to the source code of your Scheme system's reader, you might want
+;;; to implement this extension.
+
+;;; If you find that this code loads or runs slowly, consider
+;;; switching to faster hardware or a faster implementation of
+;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
+;;; compiling (with full optimization), and loading this file takes
+;;; between one and two seconds.
+
+;;; In the expander implementation, we sometimes use syntactic abstractions
+;;; when procedural abstractions would suffice. For example, we define
+;;; top-wrap and top-marked? as
+;;; (define-syntax top-wrap (identifier-syntax '((top))))
+;;; (define-syntax top-marked?
+;;; (syntax-rules ()
+;;; ((_ w) (memq 'top (wrap-marks w)))))
+;;; rather than
+;;; (define top-wrap '((top)))
+;;; (define top-marked?
+;;; (lambda (w) (memq 'top (wrap-marks w))))
+;;; On ther other hand, we don't do this consistently; we define make-wrap,
+;;; wrap-marks, and wrap-subst simply as
+;;; (define make-wrap cons)
+;;; (define wrap-marks car)
+;;; (define wrap-subst cdr)
+;;; In Chez Scheme, the syntactic and procedural forms of these
+;;; abstractions are equivalent, since the optimizer consistently
+;;; integrates constants and small procedures. Some Scheme
+;;; implementations, however, may benefit from more consistent use
+;;; of one form or the other.
+
+
+;;; Implementation notes:
+
+;;; "begin" is treated as a splicing construct at top level and at
+;;; the beginning of bodies. Any sequence of expressions that would
+;;; be allowed where the "begin" occurs is allowed.
+
+;;; "let-syntax" and "letrec-syntax" are also treated as splicing
+;;; constructs, in violation of the R5RS. A consequence is that let-syntax
+;;; and letrec-syntax do not create local contours, as do let and letrec.
+;;; Although the functionality is greater as it is presently implemented,
+;;; we will probably change it to conform to the R5RS. modules provide
+;;; similar functionality to nonsplicing letrec-syntax when the latter is
+;;; used as a definition.
+
+;;; Objects with no standard print syntax, including objects containing
+;;; cycles and syntax objects, are allowed in quoted data as long as they
+;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; Such objects are never copied.
+
+;;; When the expander encounters a reference to an identifier that has
+;;; no global or lexical binding, it treats it as a global-variable
+;;; reference. This allows one to write mutually recursive top-level
+;;; definitions, e.g.:
+;;;
+;;; (define f (lambda (x) (g x)))
+;;; (define g (lambda (x) (f x)))
+;;;
+;;; but may not always yield the intended when the variable in question
+;;; is later defined as a keyword.
+
+;;; Top-level variable definitions of syntax keywords are permitted.
+;;; In order to make this work, top-level define not only produces a
+;;; top-level definition in the core language, but also modifies the
+;;; compile-time environment (using $sc-put-cte) to record the fact
+;;; that the identifier is a variable.
+
+;;; Top-level definitions of macro-introduced identifiers are visible
+;;; only in code produced by the macro. That is, a binding for a
+;;; hidden (generated) identifier is created instead, and subsequent
+;;; references within the macro output are renamed accordingly. For
+;;; example:
+;;;
+;;; (define-syntax a
+;;; (syntax-rules ()
+;;; ((_ var exp)
+;;; (begin
+;;; (define secret exp)
+;;; (define var
+;;; (lambda ()
+;;; (set! secret (+ secret 17))
+;;; secret))))))
+;;; (a x 0)
+;;; (x) => 17
+;;; (x) => 34
+;;; secret => Error: variable secret is not bound
+;;;
+;;; The definition above would fail if the definition for secret
+;;; were placed after the definition for var, since the expander would
+;;; encounter the references to secret before the definition that
+;;; establishes the compile-time map from the identifier secret to
+;;; the generated identifier.
+
+;;; Identifiers and syntax objects are implemented as vectors for
+;;; portability. As a result, it is possible to "forge" syntax
+;;; objects.
+
+;;; The input to sc-expand may contain "annotations" describing, e.g., the
+;;; source file and character position from where each object was read if
+;;; it was read from a file. These annotations are handled properly by
+;;; sc-expand only if the annotation? hook (see hooks below) is implemented
+;;; properly and the operators make-annotation, annotation-expression,
+;;; annotation-source, annotation-stripped, and set-annotation-stripped!
+;;; are supplied. If annotations are supplied, the proper annotation
+;;; source is passed to the various output constructors, allowing
+;;; implementations to accurately correlate source and expanded code.
+;;; Contact one of the authors for details if you wish to make use of
+;;; this feature.
+
+;;; Implementation of modules:
+;;;
+;;; The implementation of modules requires that implicit top-level exports
+;;; be listed with the exported macro at some level where both are visible,
+;;; e.g.,
+;;;
+;;; (module M (alpha (beta b))
+;;; (module ((alpha a) b)
+;;; (define-syntax alpha (identifier-syntax a))
+;;; (define a 'a)
+;;; (define b 'b))
+;;; (define-syntax beta (identifier-syntax b)))
+;;;
+;;; Listing of implicit imports is not needed for macros that do not make
+;;; it out to top level, including all macros that are local to a "body".
+;;; (They may be listed in this case, however.) We need this information
+;;; for top-level modules since a top-level module expands into a letrec
+;;; for non-top-level variables and top-level definitions (assignments) for
+;;; top-level variables. Because of the general nature of macro
+;;; transformers, we cannot determine the set of implicit exports from the
+;;; transformer code, so without the user's help, we'd have to put all
+;;; variables at top level.
+;;;
+;;; Each such top-level identifier is given a generated name (gensym).
+;;; When a top-level module is imported at top level, a compile-time
+;;; alias is established from the top-level name to the generated name.
+;;; The expander follows these aliases transparently. When any module is
+;;; imported anywhere other than at top level, the id-var-name of the
+;;; import identifier is set to the id-var-name of the export identifier.
+;;; Since we can't determine the actual labels for identifiers defined in
+;;; top-level modules until we determine which are placed in the letrec
+;;; and which make it to top level, we give each an "indirect" label---a
+;;; pair whose car will eventually contain the actual label. Import does
+;;; not follow the indirect, but id-var-name does.
+;;;
+;;; All identifiers defined within a local module are folded into the
+;;; letrec created for the enclosing body. Visibility is controlled in
+;;; this case and for nested top-level modules by introducing a new wrap
+;;; for each module.
+
+
+;;; Bootstrapping:
+
+;;; When changing syntax-object representations, it is necessary to support
+;;; both old and new syntax-object representations in id-var-name. It
+;;; should be sufficient to recognize old representations and treat
+;;; them as not lexically bound.
+
+
+(let ()
+
+(define-syntax when
+ (syntax-rules ()
+ ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
+(define-syntax unless
+ (syntax-rules ()
+ ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
+(define-syntax define-structure
+ (lambda (x)
+ (define construct-name
+ (lambda (template-identifier . args)
+ (datum->syntax-object
+ template-identifier
+ (string->symbol
+ (apply string-append
+ (map (lambda (x)
+ (if (string? x)
+ x
+ (symbol->string (syntax-object->datum x))))
+ args))))))
+ (syntax-case x ()
+ ((_ (name id1 ...))
+ (andmap identifier? (syntax (name id1 ...)))
+ (with-syntax
+ ((constructor (construct-name (syntax name) "make-" (syntax name)))
+ (predicate (construct-name (syntax name) (syntax name) "?"))
+ ((access ...)
+ (map (lambda (x) (construct-name x (syntax name) "-" x))
+ (syntax (id1 ...))))
+ ((assign ...)
+ (map (lambda (x)
+ (construct-name x "set-" (syntax name) "-" x "!"))
+ (syntax (id1 ...))))
+ (structure-length
+ (+ (length (syntax (id1 ...))) 1))
+ ((index ...)
+ (let f ((i 1) (ids (syntax (id1 ...))))
+ (if (null? ids)
+ '()
+ (cons i (f (+ i 1) (cdr ids)))))))
+ (syntax (begin
+ (define constructor
+ (lambda (id1 ...)
+ (vector 'name id1 ... )))
+ (define predicate
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) structure-length)
+ (eq? (vector-ref x 0) 'name))))
+ (define access
+ (lambda (x)
+ (vector-ref x index)))
+ ...
+ (define assign
+ (lambda (x update)
+ (vector-set! x index update)))
+ ...)))))))
+
+(define noexpand "noexpand")
+
+;;; hooks to nonportable run-time helpers
+(begin
+(define-syntax fx+ (identifier-syntax +))
+(define-syntax fx- (identifier-syntax -))
+(define-syntax fx= (identifier-syntax =))
+(define-syntax fx< (identifier-syntax <))
+
+(define annotation? (lambda (x) #f))
+
+(define top-level-eval-hook
+ (lambda (x)
+ (eval `(,noexpand ,x))))
+
+(define local-eval-hook
+ (lambda (x)
+ (eval `(,noexpand ,x))))
+
+(define error-hook
+ (lambda (who why what)
+ (error who "~a ~s" why what)))
+
+(define-syntax gensym-hook
+ (syntax-rules ()
+ ((_) (gensym))))
+
+(define put-global-definition-hook
+ (lambda (symbol val)
+ ($sc-put-cte symbol val)))
+
+(define get-global-definition-hook
+ (lambda (symbol)
+ (getprop symbol '*sc-expander*)))
+
+(define get-import-binding
+ (lambda (symbol token)
+ (getprop symbol token)))
+
+(define generate-id
+ (let ((b (- 127 32 2)))
+ ; session-key should generate a unique integer for each system run
+ ; to support separate compilation
+ (define session-key (lambda () 0))
+ (define make-digit (lambda (x) (integer->char (fx+ x 33))))
+ (define fmt
+ (lambda (n)
+ (let fmt ((n n) (a '()))
+ (if (< n b)
+ (list->string (cons (make-digit n) a))
+ (let ((r (modulo n b)) (rest (quotient n b)))
+ (fmt rest (cons (make-digit r) a)))))))
+ (let ((prefix (fmt (session-key))) (n -1))
+ (lambda (name)
+ (set! n (+ n 1))
+ (let ((newsym (string->symbol (string-append "#" prefix (fmt n)))))
+ newsym)))))
+)
+
+
+;;; output constructors
+(begin
+(define-syntax build-application
+ (syntax-rules ()
+ ((_ source fun-exp arg-exps)
+ `(,fun-exp . ,arg-exps))))
+
+(define-syntax build-conditional
+ (syntax-rules ()
+ ((_ source test-exp then-exp else-exp)
+ `(if ,test-exp ,then-exp ,else-exp))))
+
+(define-syntax build-lexical-reference
+ (syntax-rules ()
+ ((_ type source var)
+ var)))
+
+(define-syntax build-lexical-assignment
+ (syntax-rules ()
+ ((_ source var exp)
+ `(set! ,var ,exp))))
+
+(define-syntax build-global-reference
+ (syntax-rules ()
+ ((_ source var)
+ var)))
+
+(define-syntax build-global-assignment
+ (syntax-rules ()
+ ((_ source var exp)
+ `(set! ,var ,exp))))
+
+(define-syntax build-global-definition
+ (syntax-rules ()
+ ((_ source var exp)
+ `(define ,var ,exp))))
+
+(define-syntax build-module-definition
+ ; should have the effect of a global definition but may not appear at top level
+ (identifier-syntax build-global-assignment))
+
+(define-syntax build-cte-install
+ ; should build a call that has the same effect as calling the
+ ; global definition hook
+ (syntax-rules ()
+ ((_ sym exp) `($sc-put-cte ',sym ,exp))))
+
+(define-syntax build-lambda
+ (syntax-rules ()
+ ((_ src vars exp)
+ `(lambda ,vars ,exp))))
+
+(define-syntax build-primref
+ (syntax-rules ()
+ ((_ src name) name)
+ ((_ src level name) name)))
+
+(define-syntax build-data
+ (syntax-rules ()
+ ((_ src exp) `',exp)))
+
+(define build-sequence
+ (lambda (src exps)
+ (if (null? (cdr exps))
+ (car exps)
+ `(begin ,@exps))))
+
+(define build-letrec
+ (lambda (src vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ `(letrec ,(map list vars val-exps) ,body-exp))))
+
+(define-syntax build-lexical-var
+ (syntax-rules ()
+ ((_ src id) (gensym))))
+
+(define-syntax self-evaluating?
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
+)
+
+(define-structure (syntax-object expression wrap))
+
+(define-syntax unannotate
+ (syntax-rules ()
+ ((_ x)
+ (let ((e x))
+ (if (annotation? e)
+ (annotation-expression e)
+ e)))))
+
+(define-syntax no-source (identifier-syntax #f))
+
+(define source-annotation
+ (lambda (x)
+ (cond
+ ((annotation? x) (annotation-source x))
+ ((syntax-object? x) (source-annotation (syntax-object-expression x)))
+ (else no-source))))
+
+(define-syntax arg-check
+ (syntax-rules ()
+ ((_ pred? e who)
+ (let ((x e))
+ (if (not (pred? x)) (error-hook who "invalid argument" x))))))
+
+;;; compile-time environments
+
+;;; wrap and environment comprise two level mapping.
+;;; wrap : id --> label
+;;; env : label --> <element>
+
+;;; environments are represented in two parts: a lexical part and a global
+;;; part. The lexical part is a simple list of associations from labels
+;;; to bindings. The global part is implemented by
+;;; {put,get}-global-definition-hook and associates symbols with
+;;; bindings.
+
+;;; global (assumed global variable) and displaced-lexical (see below)
+;;; do not show up in any environment; instead, they are fabricated by
+;;; lookup when it finds no other bindings.
+
+;;; <environment> ::= ((<label> . <binding>)*)
+
+;;; identifier bindings include a type and a value
+
+;;; <binding> ::= (macro . <procedure>) macros
+;;; (deferred . <expanded code>) lazy-evaluation of transformers
+;;; (core . <procedure>) core forms
+;;; (begin) begin
+;;; (define) define
+;;; (define-syntax) define-syntax
+;;; (local-syntax . rec?) let-syntax/letrec-syntax
+;;; (eval-when) eval-when
+;;; (syntax . (<var> . <level>)) pattern variables
+;;; (global . <symbol>) assumed global variable
+;;; (lexical . <var>) lexical variables
+;;; (displaced-lexical . #f) id-var-name not found in store
+;;; <level> ::= <nonnegative integer>
+;;; <var> ::= variable returned by build-lexical-var
+
+;;; a macro is a user-defined syntactic-form. a core is a system-defined
+;;; syntactic form. begin, define, define-syntax, and eval-when are
+;;; treated specially since they are sensitive to whether the form is
+;;; at top-level and (except for eval-when) can denote valid internal
+;;; definitions.
+
+;;; a pattern variable is a variable introduced by syntax-case and can
+;;; be referenced only within a syntax form.
+
+;;; any identifier for which no top-level syntax definition or local
+;;; binding of any kind has been seen is assumed to be a global
+;;; variable.
+
+;;; a lexical variable is a lambda- or letrec-bound variable.
+
+;;; a displaced-lexical identifier is a lexical identifier removed from
+;;; it's scope by the return of a syntax object containing the identifier.
+;;; a displaced lexical can also appear when a letrec-syntax-bound
+;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
+;;; a displaced lexical should never occur with properly written macros.
+
+(define make-binding (lambda (x y) (cons x y)))
+(define binding-type car)
+(define binding-value cdr)
+(define set-binding-type! set-car!)
+(define set-binding-value! set-cdr!)
+(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
+
+(define-syntax null-env (identifier-syntax '()))
+
+(define extend-env
+ (lambda (label binding r)
+ (cons (cons label binding) r)))
+
+(define extend-env*
+ (lambda (labels bindings r)
+ (if (null? labels)
+ r
+ (extend-env* (cdr labels) (cdr bindings)
+ (extend-env (car labels) (car bindings) r)))))
+
+(define extend-var-env*
+ ; variant of extend-env* that forms "lexical" binding
+ (lambda (labels vars r)
+ (if (null? labels)
+ r
+ (extend-var-env* (cdr labels) (cdr vars)
+ (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
+
+;;; we use a "macros only" environment in expansion of local macro
+;;; definitions so that their definitions can use local macros without
+;;; attempting to use other lexical identifiers.
+;;;
+;;; - can make this null-env if we don't want to allow macros to use other
+;;; macros in defining their transformers
+;;; - can add a cache here if it pays off
+(define transformer-env
+ (lambda (r)
+ (if (null? r)
+ '()
+ (let ((a (car r)))
+ (if (eq? (cadr a) 'lexical) ; only strip out lexical so that (transformer x) works
+ (transformer-env (cdr r))
+ (cons a (transformer-env (cdr r))))))))
+
+(define displaced-lexical-error
+ (lambda (id)
+ (syntax-error id
+ (if (id-var-name id empty-wrap)
+ "identifier out of context"
+ "identifier not visible"))))
+
+(define lookup*
+ ; x may be a label or a symbol
+ ; although symbols are usually global, we check the environment first
+ ; anyway because a temporary binding may have been established by
+ ; fluid-let-syntax
+ (lambda (x r)
+ (cond
+ ((assq x r) => cdr)
+ ((symbol? x)
+ (or (get-global-definition-hook x) (make-binding 'global x)))
+ (else (make-binding 'displaced-lexical #f)))))
+
+(define sanitize-binding
+ (lambda (b)
+ (cond
+ ((procedure? b) (make-binding 'macro b))
+ ((binding? b)
+ (case (binding-type b)
+ ((core macro macro!) (and (procedure? (binding-value b)) b))
+ ((module) (and (interface? (binding-value b)) b))
+ (else b)))
+ (else #f))))
+
+(define lookup
+ (lambda (x r)
+ (define whack-binding!
+ (lambda (b *b)
+ (set-binding-type! b (binding-type *b))
+ (set-binding-value! b (binding-value *b))))
+ (let ((b (lookup* x r)))
+ (case (binding-type b)
+; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
+ ((deferred)
+ (whack-binding! b
+ (let ((*b (local-eval-hook (binding-value b))))
+ (or (sanitize-binding *b)
+ (syntax-error *b "invalid transformer"))))
+ (case (binding-type b)
+; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
+ (else b)))
+ (else b)))))
+
+(define global-extend
+ (lambda (type sym val)
+ (put-global-definition-hook sym (make-binding type val))))
+
+
+;;; Conceptually, identifiers are always syntax objects. Internally,
+;;; however, the wrap is sometimes maintained separately (a source of
+;;; efficiency and confusion), so that symbols are also considered
+;;; identifiers by id?. Externally, they are always wrapped.
+
+(define nonsymbol-id?
+ (lambda (x)
+ (and (syntax-object? x)
+ (symbol? (unannotate (syntax-object-expression x))))))
+
+(define id?
+ (lambda (x)
+ (cond
+ ((symbol? x) #t)
+ ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
+ ((annotation? x) (symbol? (annotation-expression x)))
+ (else #f))))
+
+(define-syntax id-sym-name
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
+
+(define id-sym-name&marks
+ (lambda (x w)
+ (if (syntax-object? x)
+ (values
+ (unannotate (syntax-object-expression x))
+ (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (values (unannotate x) (wrap-marks w)))))
+
+;;; syntax object wraps
+
+;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+;;; <subst> ::= <ribcage> | <shift>
+;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
+;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
+;;; <ex-symname> ::= <symname> | <import token> | <barrier>
+;;; <shift> ::= shift
+;;; <barrier> ::= #f ; inserted by import-only
+;;; <import token> ::= #<"import-token" <token>>
+;;; <token> ::= <generated id>
+
+(define make-wrap cons)
+(define wrap-marks car)
+(define wrap-subst cdr)
+
+(define-syntax subst-rename? (identifier-syntax vector?))
+(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
+(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
+(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
+(define-syntax make-rename
+ (syntax-rules ()
+ ((_ old new marks) (vector old new marks))))
+
+;;; labels
+
+;;; simple labels must be comparable with "eq?" and distinct from symbols
+;;; and pairs.
+
+;;; indirect labels, which are implemented as pairs, are used to support
+;;; import aliasing for identifiers exported (explictly or implicitly) from
+;;; top-level modules. chi-external creates an indirect label for each
+;;; defined identifier, import causes the pair to be shared aliases it
+;;; establishes, and chi-top-module whacks the pair to hold the top-level
+;;; identifier name (symbol) if the id is to be placed at top level, before
+;;; expanding the right-hand sides of the definitions in the module.
+
+(define gen-label
+ (lambda () (string #\i)))
+(define label?
+ (lambda (x)
+ (or (string? x) ; normal lexical labels
+ (symbol? x) ; global labels (symbolic names)
+ (indirect-label? x))))
+
+(define gen-labels
+ (lambda (ls)
+ (if (null? ls)
+ '()
+ (cons (gen-label) (gen-labels (cdr ls))))))
+
+(define gen-indirect-label
+ (lambda () (list (gen-label))))
+
+(define indirect-label? pair?)
+(define get-indirect-label car)
+(define set-indirect-label! set-car!)
+
+(define-structure (ribcage symnames marks labels))
+(define-syntax empty-wrap (identifier-syntax '(())))
+
+(define-syntax top-wrap (identifier-syntax '((top))))
+
+(define-syntax top-marked?
+ (syntax-rules ()
+ ((_ w) (memq 'top (wrap-marks w)))))
+
+(define-syntax only-top-marked?
+ (syntax-rules ()
+ ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
+
+;;; Marks must be comparable with "eq?" and distinct from pairs and
+;;; the symbol top. We do not use integers so that marks will remain
+;;; unique even across file compiles.
+
+(define-syntax the-anti-mark (identifier-syntax #f))
+
+(define anti-mark
+ (lambda (w)
+ (make-wrap (cons the-anti-mark (wrap-marks w))
+ (cons 'shift (wrap-subst w)))))
+
+(define-syntax new-mark
+ (syntax-rules ()
+ ((_) (string #\m))))
+
+(define barrier-marker #f)
+(module (make-import-token import-token? import-token-key)
+ (define tag 'import-token)
+ (define make-import-token (lambda (x) (cons tag x)))
+ (define import-token? (lambda (x) (and (pair? x) (eq? (car x) tag))))
+ (define import-token-key cdr))
+
+;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
+;;; internal definitions, in which the ribcages are built incrementally
+(define-syntax make-empty-ribcage
+ (syntax-rules ()
+ ((_) (make-ribcage '() '() '()))))
+
+(define extend-ribcage!
+ ; must receive ids with complete wraps
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage id label)
+ (set-ribcage-symnames! ribcage
+ (cons (unannotate (syntax-object-expression id))
+ (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks (syntax-object-wrap id))
+ (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage
+ (cons label (ribcage-labels ribcage)))))
+
+(define extend-ribcage-barrier!
+ ; must receive ids with complete wraps
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage killer-id)
+ (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
+
+(define extend-ribcage-barrier-help!
+ (lambda (ribcage wrap)
+ (set-ribcage-symnames! ribcage
+ (cons barrier-marker (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
+
+(define extend-ribcage-subst!
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage token)
+ (set-ribcage-symnames! ribcage
+ (cons (make-import-token token) (ribcage-symnames ribcage)))))
+
+(define lookup-import-binding-name
+ (lambda (sym key marks)
+ (let ((new (get-import-binding sym key)))
+ (and new
+ (let f ((new new))
+ (cond
+ ((pair? new) (or (f (car new)) (f (cdr new))))
+ ((same-marks? marks (wrap-marks (syntax-object-wrap new))) new)
+ (else #f)))))))
+
+;;; make-binding-wrap creates vector-based ribcages
+(define make-binding-wrap
+ (lambda (ids labels w)
+ (if (null? ids)
+ w
+ (make-wrap
+ (wrap-marks w)
+ (cons
+ (let ((labelvec (list->vector labels)))
+ (let ((n (vector-length labelvec)))
+ (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
+ (let f ((ids ids) (i 0))
+ (if (not (null? ids))
+ (call-with-values
+ (lambda () (id-sym-name&marks (car ids) w))
+ (lambda (symname marks)
+ (vector-set! symnamevec i symname)
+ (vector-set! marksvec i marks)
+ (f (cdr ids) (fx+ i 1))))))
+ (make-ribcage symnamevec marksvec labelvec))))
+ (wrap-subst w))))))
+
+;;; make-trimmed-syntax-object is used by make-resolved-interface to support
+;;; creation of module export lists whose constituent ids do not contain
+;;; unnecessary substitutions or marks.
+(define make-trimmed-syntax-object
+ (lambda (id)
+ (call-with-values
+ (lambda () (id-var-name&marks id empty-wrap))
+ (lambda (tosym marks)
+ (unless tosym
+ (syntax-error id "identifier not visible for export"))
+ (let ((fromsym (id-sym-name id)))
+ (make-syntax-object fromsym
+ (make-wrap marks
+ (list (make-ribcage (vector fromsym) (vector marks) (vector tosym))))))))))
+
+;;; Scheme's append should not copy the first argument if the second is
+;;; nil, but it does, so we define a smart version here.
+(define smart-append
+ (lambda (m1 m2)
+ (if (null? m2)
+ m1
+ (append m1 m2))))
+
+(define join-wraps
+ (lambda (w1 w2)
+ (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
+ (if (null? m1)
+ (if (null? s1)
+ w2
+ (make-wrap
+ (wrap-marks w2)
+ (smart-append s1 (wrap-subst w2))))
+ (make-wrap
+ (smart-append m1 (wrap-marks w2))
+ (smart-append s1 (wrap-subst w2)))))))
+
+(define join-marks
+ (lambda (m1 m2)
+ (smart-append m1 m2)))
+
+(define same-marks?
+ (lambda (x y)
+ (or (eq? x y)
+ (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y))
+ (same-marks? (cdr x) (cdr y))))))
+
+(define id-var-name-loc&marks
+ (lambda (id w)
+ (define search
+ (lambda (sym subst marks)
+ (if (null? subst)
+ (values sym marks)
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (search sym (cdr subst) (cdr marks))
+ (let ((symnames (ribcage-symnames fst)))
+ (if (vector? symnames)
+ (search-vector-rib sym subst marks symnames fst)
+ (search-list-rib sym subst marks symnames fst))))))))
+ (define search-list-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let f ((symnames symnames) (i 0))
+ (cond
+ ((null? symnames) (search sym (cdr subst) marks))
+ ((and (eq? (car symnames) sym)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values (list-ref (ribcage-labels ribcage) i) marks))
+ ((import-token? (car symnames))
+ (cond
+ ((lookup-import-binding-name sym (import-token-key (car symnames)) marks) =>
+ (lambda (id)
+ (if (symbol? id)
+ (values id marks)
+ (id-var-name&marks id empty-wrap)))) ; could be more efficient: new is a resolved id
+ (else (f (cdr symnames) i))))
+ ((and (eq? (car symnames) barrier-marker)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values #f marks))
+ (else (f (cdr symnames) (fx+ i 1)))))))
+ (define search-vector-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0))
+ (cond
+ ((fx= i n) (search sym (cdr subst) marks))
+ ((and (eq? (vector-ref symnames i) sym)
+ (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
+ (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (else (f (fx+ i 1))))))))
+ (cond
+ ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
+ ((syntax-object? id)
+ (let ((sym (unannotate (syntax-object-expression id)))
+ (w1 (syntax-object-wrap id)))
+ (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
+ (call-with-values (lambda () (search sym (wrap-subst w) marks))
+ (lambda (new-id marks)
+ (if (eq? new-id sym)
+ (search sym (wrap-subst w1) marks)
+ (values new-id marks)))))))
+ ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
+ (else (error-hook 'id-var-name "invalid id" id)))))
+
+(define id-var-name&marks
+ ; this version follows indirect labels
+ (lambda (id w)
+ (call-with-values
+ (lambda () (id-var-name-loc&marks id w))
+ (lambda (label marks)
+ (values (if (indirect-label? label) (get-indirect-label label) label) marks)))))
+
+(define id-var-name-loc
+ ; this version doesn't follow indirect labels
+ (lambda (id w)
+ (call-with-values
+ (lambda () (id-var-name-loc&marks id w))
+ (lambda (label marks) label))))
+
+(define id-var-name
+ ; this version follows indirect labels
+ (lambda (id w)
+ (call-with-values
+ (lambda () (id-var-name-loc&marks id w))
+ (lambda (label marks)
+ (if (indirect-label? label) (get-indirect-label label) label)))))
+
+;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
+;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
+
+(define free-id=?
+ (lambda (i j)
+ (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
+ (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
+
+(define-syntax literal-id=? (identifier-syntax free-id=?))
+
+;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
+;;; long as the missing portion of the wrap is common to both of the ids
+;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
+
+(define bound-id=?
+ (lambda (i j)
+ (if (and (syntax-object? i) (syntax-object? j))
+ (and (eq? (unannotate (syntax-object-expression i))
+ (unannotate (syntax-object-expression j)))
+ (same-marks? (wrap-marks (syntax-object-wrap i))
+ (wrap-marks (syntax-object-wrap j))))
+ (eq? (unannotate i) (unannotate j)))))
+
+;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
+;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
+;;; as long as the missing portion of the wrap is common to all of the
+;;; ids.
+
+(define valid-bound-ids?
+ (lambda (ids)
+ (and (let all-ids? ((ids ids))
+ (or (null? ids)
+ (and (id? (car ids))
+ (all-ids? (cdr ids)))))
+ (distinct-bound-ids? ids))))
+
+;;; distinct-bound-ids? expects a list of ids and returns #t if there are
+;;; no duplicates. It is quadratic on the length of the id list; long
+;;; lists could be sorted to make it more efficient. distinct-bound-ids?
+;;; may be passed unwrapped (or partially wrapped) ids as long as the
+;;; missing portion of the wrap is common to all of the ids.
+
+(define distinct-bound-ids?
+ (lambda (ids)
+ (let distinct? ((ids ids))
+ (or (null? ids)
+ (and (not (bound-id-member? (car ids) (cdr ids)))
+ (distinct? (cdr ids)))))))
+
+(define invalid-ids-error
+ ; find first bad one and complain about it
+ (lambda (ids exp class)
+ (let find ((ids ids) (gooduns '()))
+ (if (null? ids)
+ (syntax-error exp) ; shouldn't happen
+ (if (id? (car ids))
+ (if (bound-id-member? (car ids) gooduns)
+ (syntax-error (car ids) "duplicate " class)
+ (find (cdr ids) (cons (car ids) gooduns)))
+ (syntax-error (car ids) "invalid " class))))))
+
+(define bound-id-member?
+ (lambda (x list)
+ (and (not (null? list))
+ (or (bound-id=? x (car list))
+ (bound-id-member? x (cdr list))))))
+
+;;; wrapping expressions and identifiers
+
+(define wrap
+ (lambda (x w)
+ (cond
+ ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
+ ((syntax-object? x)
+ (make-syntax-object
+ (syntax-object-expression x)
+ (join-wraps w (syntax-object-wrap x))))
+ ((null? x) x)
+ (else (make-syntax-object x w)))))
+
+(define source-wrap
+ (lambda (x w s)
+ (wrap (if s (make-annotation x s #f) x) w)))
+
+;;; expanding
+
+(define chi-sequence
+ (lambda (body r w s)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w))
+ (if (null? body)
+ '()
+ (let ((first (chi (car body) r w)))
+ (cons first (dobody (cdr body) r w))))))))
+
+(define chi-top-sequence
+ (lambda (body r w s m esew ribcage)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w) (m m) (esew esew))
+ (if (null? body)
+ '()
+ (let ((first (chi-top (car body) r w m esew ribcage)))
+ (cons first (dobody (cdr body) r w m esew))))))))
+
+(define chi-when-list
+ (lambda (e when-list w)
+ ; when-list is syntax'd version of list of situations
+ (let f ((when-list when-list) (situations '()))
+ (if (null? when-list)
+ situations
+ (f (cdr when-list)
+ (cons (let ((x (car when-list)))
+ (cond
+ ((literal-id=? x (syntax compile)) 'compile)
+ ((literal-id=? x (syntax load)) 'load)
+ ((literal-id=? x (syntax eval)) 'eval)
+ (else (syntax-error (wrap x w)
+ "invalid eval-when situation"))))
+ situations))))))
+
+;;; syntax-type returns five values: type, value, e, w, and s. The first
+;;; two are described in the table below.
+;;;
+;;; type value explanation
+;;; -------------------------------------------------------------------
+;;; begin none begin keyword
+;;; begin-form none begin expression
+;;; call none any other call
+;;; constant none self-evaluating datum
+;;; core procedure core form (including singleton)
+;;; define none define keyword
+;;; define-form none variable definition
+;;; define-syntax none define-syntax keyword
+;;; define-syntax-form none syntax definition
+;;; displaced-lexical none displaced lexical identifier
+;;; eval-when none eval-when keyword
+;;; eval-when-form none eval-when form
+;;; global name global variable reference
+;;; import none import keyword
+;;; import-form none import form
+;;; lexical name lexical variable reference
+;;; lexical-call name call to lexical variable
+;;; local-syntax rec? letrec-syntax/let-syntax keyword
+;;; local-syntax-form rec? syntax definition
+;;; module none module keyword
+;;; module-form none module definition
+;;; other none anything else
+;;; syntax level pattern variable
+;;;
+;;; For all forms, e is the form, w is the wrap for e. and s is the source.
+;;;
+;;; syntax-type expands macros and unwraps as necessary to get to
+;;; one of the forms above.
+
+(define syntax-type
+ (lambda (e r w s rib)
+ (cond
+ ((symbol? e)
+ (let* ((n (id-var-name e w))
+ (b (lookup n r))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values type (binding-value b) e w s))
+ ((global) (values type (binding-value b) e w s))
+ ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w s rib) r empty-wrap #f rib))
+ (else (values type (binding-value b) e w s)))))
+ ((pair? e)
+ (let ((first (car e)))
+ (if (id? first)
+ (let* ((n (id-var-name first w))
+ (b (lookup n r))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values 'lexical-call (binding-value b) e w s))
+ ((macro macro!)
+ (syntax-type (chi-macro (binding-value b) e r w s rib)
+ r empty-wrap #f rib))
+ ((core) (values type (binding-value b) e w s))
+ ((local-syntax)
+ (values 'local-syntax-form (binding-value b) e w s))
+ ((begin) (values 'begin-form #f e w s))
+ ((eval-when) (values 'eval-when-form #f e w s))
+ ((define) (values 'define-form #f e w s))
+ ((define-syntax) (values 'define-syntax-form #f e w s))
+ ((module-key) (values 'module-form #f e w s))
+ ((import) (values 'import-form (and (binding-value b) (wrap first w)) e w s))
+ ((set!) (chi-set! e r w s rib))
+ (else (values 'call #f e w s))))
+ (values 'call #f e w s))))
+ ((syntax-object? e)
+ ;; s can't be valid source if we've unwrapped
+ (syntax-type (syntax-object-expression e)
+ r
+ (join-wraps w (syntax-object-wrap e))
+ no-source rib))
+ ((annotation? e)
+ (syntax-type (annotation-expression e) r w (annotation-source e) rib))
+ ((self-evaluating? e) (values 'constant #f e w s))
+ (else (values 'other #f e w s)))))
+
+(define chi-top-expr
+ (lambda (e r w top-ribcage)
+ (call-with-values
+ (lambda () (syntax-type e r w no-source top-ribcage))
+ (lambda (type value e w s)
+ (chi-expr type value e r w s)))))
+
+(define chi-top
+ (lambda (e r w m esew top-ribcage)
+ (define-syntax eval-if-c&e
+ (syntax-rules ()
+ ((_ m e)
+ (let ((x e))
+ (if (eq? m 'c&e) (top-level-eval-hook x))
+ x))))
+ (call-with-values
+ (lambda () (syntax-type e r w no-source top-ribcage))
+ (lambda (type value e w s)
+ (case type
+ ((begin-form)
+ (syntax-case e ()
+ ((_) (chi-void))
+ ((_ e1 e2 ...)
+ (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew top-ribcage))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s
+ (lambda (body r w s)
+ (chi-top-sequence body r w s m esew top-ribcage))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e (syntax (x ...)) w))
+ (body (syntax (e1 e2 ...))))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (chi-top-sequence body r w s 'e '(eval) top-ribcage)
+ (chi-void)))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (chi-top-sequence body r w s 'c&e '(compile load) top-ribcage)
+ (if (memq m '(c c&e))
+ (chi-top-sequence body r w s 'c '(load) top-ribcage)
+ (chi-void))))
+ ((or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (chi-top-sequence body r w s 'e '(eval) top-ribcage))
+ (chi-void))
+ (else (chi-void)))))))
+ ((define-syntax-form)
+ (parse-define-syntax e w s
+ (lambda (id rhs w)
+ (let ((id (wrap id w)))
+ (let ((n (id-var-name id empty-wrap)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((displaced-lexical) (displaced-lexical-error id)))))
+ (ct-eval/residualize m esew
+ (lambda ()
+ (build-cte-install
+ (let ((sym (id-sym-name id)))
+ (if (only-top-marked? id)
+ sym
+ (let ((marks (wrap-marks (syntax-object-wrap id))))
+ (make-syntax-object sym
+ (make-wrap marks
+ (list (make-ribcage (vector sym)
+ (vector marks) (vector (generate-id sym)))))))))
+ (chi rhs (transformer-env r) w))))))))
+ ((define-form)
+ (parse-define e w s
+ (lambda (id rhs w)
+ (let ((id (wrap id w)))
+ (let ((n (id-var-name id empty-wrap)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((displaced-lexical) (displaced-lexical-error id)))))
+ (let ((sym (id-sym-name id)))
+ (let ((valsym (if (only-top-marked? id) sym (generate-id sym))))
+ (build-sequence no-source
+ (list
+ (ct-eval/residualize m esew
+ (lambda ()
+ (build-cte-install
+ (if (eq? sym valsym)
+ sym
+ (let ((marks (wrap-marks (syntax-object-wrap id))))
+ (make-syntax-object sym
+ (make-wrap marks
+ (list (make-ribcage (vector sym)
+ (vector marks) (vector valsym)))))))
+ (build-data no-source (make-binding 'global valsym)))))
+ (eval-if-c&e m (build-global-definition s valsym (chi rhs r w))))))
+ )))))
+ ((module-form)
+ (let ((r (cons '("top-level module placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage)))
+ (parse-module e w s (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))
+ (lambda (id exports forms)
+ (if id
+ (begin
+ (let ((n (id-var-name id empty-wrap)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((displaced-lexical) (displaced-lexical-error (wrap id w))))))
+ (chi-top-module e r ribcage w s m esew id exports forms))
+ (chi-top-module e r ribcage w s m esew #f exports forms))))))
+ ((import-form)
+ (parse-import e w s
+ (lambda (mid)
+ (ct-eval/residualize m esew
+ (lambda ()
+ (when value (syntax-error (source-wrap e w s) "not valid at top-level"))
+ (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
+ (case (binding-type binding)
+ ((module) (do-top-import mid (interface-token (binding-value binding))))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "import from unknown module")))))))))
+ (else (eval-if-c&e m (chi-expr type value e r w s))))))))
+
+(define flatten-exports
+ (lambda (exports)
+ (let loop ((exports exports) (ls '()))
+ (if (null? exports)
+ ls
+ (loop (cdr exports)
+ (if (pair? (car exports))
+ (loop (car exports) ls)
+ (cons (car exports) ls)))))))
+
+
+(define-structure (interface exports token))
+
+(define make-trimmed-interface
+ ; trim out implicit exports
+ (lambda (exports)
+ (make-interface
+ (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
+ #f)))
+
+(define make-resolved-interface
+ ; trim out implicit exports & resolve others to actual top-level symbol
+ (lambda (exports import-token)
+ (make-interface
+ (list->vector (map (lambda (x) (make-trimmed-syntax-object (if (pair? x) (car x) x))) exports))
+ import-token)))
+
+(define-structure (module-binding type id label imps val))
+
+(define chi-top-module
+ (lambda (e r ribcage w s m esew id exports forms)
+ (let ((fexports (flatten-exports exports)))
+ (chi-external ribcage (source-wrap e w s)
+ (map (lambda (d) (cons r d)) forms) r exports fexports m esew
+ (lambda (bindings inits)
+ ; dvs & des: "defined" (letrec-bound) vars & rhs expressions
+ ; svs & ses: "set!" (top-level) vars & rhs expressions
+ (let partition ((fexports fexports) (bs bindings) (svs '()) (ses '()) (ctdefs '()))
+ (if (null? fexports)
+ ; remaining bindings are either local vars or local macros/modules
+ (let partition ((bs bs) (dvs '()) (des '()))
+ (if (null? bs)
+ (let ((ses (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) ses))
+ (des (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) des))
+ (inits (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) inits)))
+ ; we wait to do this here so that expansion of des & ses use
+ ; local versions, which in particular, allows us to use macros
+ ; locally even if esew tells us not to eval them
+ (for-each (lambda (x)
+ (apply (lambda (t label sym val)
+ (when label (set-indirect-label! label sym)))
+ x))
+ ctdefs)
+ (build-sequence no-source
+ (list (ct-eval/residualize m esew
+ (lambda ()
+ (if (null? ctdefs)
+ (chi-void)
+ (build-sequence no-source
+ (map (lambda (x)
+ (apply (lambda (t label sym val)
+ (build-cte-install sym
+ (if (eq? t 'define-syntax-form)
+ val
+ (build-data no-source
+ (make-binding 'module
+ (make-resolved-interface val sym))))))
+ x))
+ ctdefs)))))
+ (ct-eval/residualize m esew
+ (lambda ()
+ (let ((n (if id (id-sym-name id) #f)))
+ (let* ((token (generate-id n))
+ (b (build-data no-source
+ (make-binding 'module
+ (make-resolved-interface exports token)))))
+ (if n
+ (build-cte-install
+ (if (only-top-marked? id)
+ n
+ (let ((marks (wrap-marks (syntax-object-wrap id))))
+ (make-syntax-object n
+ (make-wrap marks
+ (list (make-ribcage (vector n)
+ (vector marks) (vector (generate-id n))))))))
+ b)
+ (let ((n (generate-id 'tmp)))
+ (build-sequence no-source
+ (list (build-cte-install n b)
+ (do-top-import n token)))))))))
+ ; Some systems complain when undefined variables are assigned.
+ (build-sequence no-source
+ (map (lambda (v) (build-global-definition no-source v (chi-void))) svs))
+ (build-letrec no-source
+ dvs
+ des
+ (build-sequence no-source
+ (list
+ (if (null? svs)
+ (chi-void)
+ (build-sequence no-source
+ (map (lambda (v e)
+ (build-module-definition no-source v e))
+ svs
+ ses)))
+ (if (null? inits)
+ (chi-void)
+ (build-sequence no-source inits)))))
+ (chi-void))))
+ (let ((b (car bs)))
+ (case (module-binding-type b)
+ ((define-form)
+ (let ((var (gen-var (module-binding-id b))))
+ (extend-store! r
+ (get-indirect-label (module-binding-label b))
+ (make-binding 'lexical var))
+ (partition (cdr bs) (cons var dvs)
+ (cons (module-binding-val b) des))))
+ ((define-syntax-form module-form) (partition (cdr bs) dvs des))
+ (else (error 'sc-expand-internal "unexpected module binding type"))))))
+ (let ((id (car fexports)) (fexports (cdr fexports)))
+ (define pluck-binding
+ (lambda (id bs succ fail)
+ (let loop ((bs bs) (new-bs '()))
+ (if (null? bs)
+ (fail)
+ (if (bound-id=? (module-binding-id (car bs)) id)
+ (succ (car bs) (smart-append (reverse new-bs) (cdr bs)))
+ (loop (cdr bs) (cons (car bs) new-bs)))))))
+ (pluck-binding id bs
+ (lambda (b bs)
+ (let ((t (module-binding-type b))
+ (label (module-binding-label b))
+ (imps (module-binding-imps b)))
+ (let ((fexports (append imps fexports))
+ (sym (generate-id (id-sym-name id))))
+ (case t
+ ((define-form)
+ (set-indirect-label! label sym)
+ (partition fexports bs (cons sym svs)
+ (cons (module-binding-val b) ses)
+ ctdefs))
+ ((define-syntax-form)
+ (partition fexports bs svs ses
+ (cons (list t label sym (module-binding-val b)) ctdefs)))
+ ((module-form)
+ (let ((exports (module-binding-val b)))
+ (partition (append (flatten-exports exports) fexports) bs
+ svs ses
+ (cons (list t label sym exports) ctdefs))))
+ (else (error 'sc-expand-internal "unexpected module binding type"))))))
+ (lambda () (partition fexports bs svs ses ctdefs)))))))))))
+
+(define id-set-diff
+ (lambda (exports defs)
+ (cond
+ ((null? exports) '())
+ ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
+ (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
+
+(define extend-store!
+ (lambda (r label binding)
+ (set-cdr! r (extend-env label binding (cdr r)))))
+
+(define check-module-exports
+ ; After processing the definitions of a module this is called to verify that the
+ ; module has defined or imported each exported identifier. Because ids in fexports are
+ ; wrapped with the given ribcage, they will contain substitutions for anything defined
+ ; or imported here. These subsitutions can be used by do-import! and do-import-top! to
+ ; provide access to reexported bindings, for example.
+ (lambda (source-exp fexports ids)
+ (define defined?
+ (lambda (e ids)
+ (ormap (lambda (x)
+ (if (interface? x)
+ (let ((token (interface-token x)))
+ (if token
+ (lookup-import-binding-name (id-sym-name e) token (wrap-marks (syntax-object-wrap e)))
+ (let ((v (interface-exports x)))
+ (let lp ((i (fx- (vector-length v) 1)))
+ (and (fx>= i 0)
+ (or (bound-id=? e (vector-ref v i))
+ (lp (fx- i 1))))))))
+ (bound-id=? e x)))
+ ids)))
+ (let loop ((fexports fexports) (missing '()))
+ (if (null? fexports)
+ (unless (null? missing) (syntax-error missing "missing definition for export(s)"))
+ (let ((e (car fexports)) (fexports (cdr fexports)))
+ (if (defined? e ids)
+ (loop fexports missing)
+ (loop fexports (cons e missing))))))))
+
+(define check-defined-ids
+ (lambda (source-exp ls)
+ (define b-i=?
+ ; cope with fat-fingered top-level
+ (lambda (x y)
+ (if (symbol? x)
+ (if (symbol? y)
+ (eq? x y)
+ (and (eq? x (id-sym-name y))
+ (same-marks? (wrap-marks (syntax-object-wrap y)) (wrap-marks top-wrap))))
+ (if (symbol? y)
+ (and (eq? y (id-sym-name x))
+ (same-marks? (wrap-marks (syntax-object-wrap x)) (wrap-marks top-wrap)))
+ (bound-id=? x y)))))
+ (define vfold
+ (lambda (v p cls)
+ (let ((len (vector-length v)))
+ (let lp ((i 0) (cls cls))
+ (if (fx= i len)
+ cls
+ (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
+ (define conflicts
+ (lambda (x y cls)
+ (if (interface? x)
+ (if (interface? y)
+ (call-with-values
+ (lambda ()
+ (let ((xe (interface-exports x)) (ye (interface-exports y)))
+ (if (fx> (vector-length xe) (vector-length ye))
+ (values x ye)
+ (values y xe))))
+ (lambda (iface exports)
+ (vfold exports (lambda (id cls) (id-iface-conflicts id iface cls)) cls)))
+ (id-iface-conflicts y x cls))
+ (if (interface? y)
+ (id-iface-conflicts x y cls)
+ (if (b-i=? x y) (cons x cls) cls)))))
+ (define id-iface-conflicts
+ (lambda (id iface cls)
+ (let ((token (interface-token iface)))
+ (if token
+ (if (lookup-import-binding-name (id-sym-name id) token
+ (if (symbol? id)
+ (wrap-marks top-wrap)
+ (wrap-marks (syntax-object-wrap id))))
+ (cons id cls)
+ cls)
+ (vfold (interface-exports iface)
+ (lambda (*id cls) (if (b-i=? *id id) (cons *id cls) cls))
+ cls)))))
+ (unless (null? ls)
+ (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
+ (if (null? ls)
+ (unless (null? cls)
+ (let ((cls (syntax-object->datum cls)))
+ (syntax-error source-exp "duplicate definition for "
+ (symbol->string (car cls))
+ " in")))
+ (let lp2 ((ls2 ls) (cls cls))
+ (if (null? ls2)
+ (lp (car ls) (cdr ls) cls)
+ (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
+
+(define chi-external
+ (lambda (ribcage source-exp body r exports fexports m esew k)
+ (define return
+ (lambda (bindings ids inits)
+ (check-defined-ids source-exp ids)
+ (check-module-exports source-exp fexports ids)
+ (k bindings inits)))
+ (define get-implicit-exports
+ (lambda (id)
+ (let f ((exports exports))
+ (if (null? exports)
+ '()
+ (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
+ (flatten-exports (cdar exports))
+ (f (cdr exports)))))))
+ (define update-imp-exports
+ (lambda (bindings exports)
+ (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
+ (map (lambda (b)
+ (let ((id (module-binding-id b)))
+ (if (not (bound-id-member? id exports))
+ b
+ (make-module-binding
+ (module-binding-type b)
+ id
+ (module-binding-label b)
+ (append (get-implicit-exports id) (module-binding-imps b))
+ (module-binding-val b)))))
+ bindings))))
+ (let parse ((body body) (ids '()) (bindings '()) (inits '()))
+ (if (null? body)
+ (return bindings ids inits)
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda () (syntax-type e er empty-wrap no-source ribcage))
+ (lambda (type value e w s)
+ (case type
+ ((define-form)
+ (parse-define e w s
+ (lambda (id rhs w)
+ (let* ((id (wrap id w))
+ (label (gen-indirect-label))
+ (imps (get-implicit-exports id)))
+ (extend-ribcage! ribcage id label)
+ (parse
+ (cdr body)
+ (cons id ids)
+ (cons (make-module-binding type id label
+ imps (cons er (wrap rhs w)))
+ bindings)
+ inits)))))
+ ((define-syntax-form)
+ (parse-define-syntax e w s
+ (lambda (id rhs w)
+ (let* ((id (wrap id w))
+ (label (gen-indirect-label))
+ (imps (get-implicit-exports id))
+ (exp (chi rhs (transformer-env er) w)))
+ ; arrange to evaluate the transformer lazily
+ (extend-store! r (get-indirect-label label) (cons 'deferred exp))
+ (extend-ribcage! ribcage id label)
+ (parse
+ (cdr body)
+ (cons id ids)
+ (cons (make-module-binding type id label imps exp)
+ bindings)
+ inits)))))
+ ((module-form)
+ (let* ((*ribcage (make-empty-ribcage))
+ (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
+ (parse-module e w s *w
+ (lambda (id *exports forms)
+ (chi-external *ribcage (source-wrap e w s)
+ (map (lambda (d) (cons er d)) forms)
+ r *exports (flatten-exports *exports) m esew
+ (lambda (*bindings *inits)
+ (let* ((iface (make-trimmed-interface *exports))
+ (bindings (append (if id *bindings (update-imp-exports *bindings *exports)) bindings))
+ (inits (append inits *inits)))
+ (if id
+ (let ((label (gen-indirect-label))
+ (imps (get-implicit-exports id)))
+ (extend-store! r (get-indirect-label label)
+ (make-binding 'module iface))
+ (extend-ribcage! ribcage id label)
+ (parse
+ (cdr body)
+ (cons id ids)
+ (cons (make-module-binding type id label imps *exports) bindings)
+ inits))
+ (let ()
+ (do-import! iface ribcage)
+ (parse (cdr body) (cons iface ids) bindings inits))))))))))
+ ((import-form)
+ (parse-import e w s
+ (lambda (mid)
+ (let ((mlabel (id-var-name mid empty-wrap)))
+ (let ((binding (lookup mlabel r)))
+ (case (binding-type binding)
+ ((module)
+ (let ((iface (binding-value binding)))
+ (when value (extend-ribcage-barrier! ribcage value))
+ (do-import! iface ribcage)
+ (parse
+ (cdr body)
+ (cons iface ids)
+ (update-imp-exports bindings (vector->list (interface-exports iface)))
+ inits)))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "import from unknown module"))))))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse (let f ((forms (syntax (e1 ...))))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids bindings inits))))
+ ((local-syntax-form)
+ (chi-local-syntax value e er w s
+ (lambda (forms er w s)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids bindings inits))))
+ (else ; found an init expression
+ (return bindings ids
+ (append inits (cons (cons er (source-wrap e w s)) (cdr body)))))))))))))
+
+(define vmap
+ (lambda (fn v)
+ (do ((i (fx- (vector-length v) 1) (fx- i 1))
+ (ls '() (cons (fn (vector-ref v i)) ls)))
+ ((fx< i 0) ls))))
+
+(define vfor-each
+ (lambda (fn v)
+ (let ((len (vector-length v)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (fn (vector-ref v i))))))
+
+(define do-top-import
+ (lambda (mid token)
+ (build-cte-install mid
+ (build-data no-source
+ (make-binding 'do-import token)))))
+
+(define ct-eval/residualize
+ (lambda (m esew thunk)
+ (case m
+ ((c) (if (memq 'compile esew)
+ (let ((e (thunk)))
+ (top-level-eval-hook e)
+ (if (memq 'load esew) e (chi-void)))
+ (if (memq 'load esew) (thunk) (chi-void))))
+ ((c&e) (let ((e (thunk))) (top-level-eval-hook e) e))
+ (else (if (memq 'eval esew) (top-level-eval-hook (thunk))) (chi-void)))))
+
+(define chi
+ (lambda (e r w)
+ (call-with-values
+ (lambda () (syntax-type e r w no-source #f))
+ (lambda (type value e w s)
+ (chi-expr type value e r w s)))))
+
+(define chi-expr
+ (lambda (type value e r w s)
+ (case type
+ ((lexical)
+ (build-lexical-reference 'value s value))
+ ((core) (value e r w s))
+ ((lexical-call)
+ (chi-application
+ (build-lexical-reference 'fun (source-annotation (car e)) value)
+ e r w s))
+ ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
+ ((global) (build-global-reference s value))
+ ((call) (chi-application (chi (car e) r w) e r w s))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s chi-sequence))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e (syntax (x ...)) w)))
+ (if (memq 'eval when-list)
+ (chi-sequence (syntax (e1 e2 ...)) r w s)
+ (chi-void))))))
+ ((define-form define-syntax-form module-form import-form)
+ (syntax-error (source-wrap e w s) "invalid context for definition"))
+ ((syntax)
+ (syntax-error (source-wrap e w s)
+ "reference to pattern variable outside syntax form"))
+ ((displaced-lexical) (displaced-lexical-error (source-wrap e w s)))
+ (else (syntax-error (source-wrap e w s))))))
+
+(define chi-application
+ (lambda (x e r w s)
+ (syntax-case e ()
+ ((e0 e1 ...)
+ (build-application s x
+ (map (lambda (e) (chi e r w)) (syntax (e1 ...)))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define chi-set!
+ (lambda (e r w s rib)
+ (syntax-case e ()
+ ((_ id val)
+ (id? (syntax id))
+ (let ((n (id-var-name (syntax id) w)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((macro!)
+ (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
+ (syntax-type (chi-macro (binding-value b)
+ `(,(syntax set!) ,id ,val)
+ r empty-wrap s rib) r empty-wrap s rib)))
+ (else
+ (values 'core
+ (lambda (e r w s)
+ ; repeat lookup in case we were first expression (init) in
+ ; module or lambda body. we repeat id-var-name as well,
+ ; although this is only necessary if we allow inits to
+ ; preced definitions
+ (let ((val (chi (syntax val) r w))
+ (n (id-var-name (syntax id) w)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((lexical) (build-lexical-assignment s (binding-value b) val))
+ ((global) (build-global-assignment s (binding-value b) val))
+ ((displaced-lexical)
+ (syntax-error (wrap (syntax id) w) "identifier out of context"))
+ (else (syntax-error (source-wrap e w s)))))))
+ e w s))))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define chi-macro
+ (lambda (p e r w s rib)
+ (define rebuild-macro-output
+ (lambda (x m)
+ (cond ((pair? x)
+ (cons (rebuild-macro-output (car x) m)
+ (rebuild-macro-output (cdr x) m)))
+ ((syntax-object? x)
+ (let ((w (syntax-object-wrap x)))
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (make-syntax-object (syntax-object-expression x)
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ (make-wrap (cdr ms)
+ (if rib (cons rib (cdr s)) (cdr s)))
+ (make-wrap (cons m ms)
+ (if rib
+ (cons rib (cons 'shift s))
+ (cons 'shift s))))))))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i n) v)
+ (vector-set! v i
+ (rebuild-macro-output (vector-ref x i) m)))))
+ ((symbol? x)
+ (syntax-error (source-wrap e w s)
+ "encountered raw symbol "
+ (format "~s" x)
+ " in output of macro"))
+ (else x))))
+ (rebuild-macro-output
+ (let ((out (p (source-wrap e (anti-mark w) s))))
+ (if (procedure? out)
+ (out (lambda (id)
+ (unless (identifier? id)
+ (syntax-error id
+ "environment argument is not an identifier"))
+ (lookup (id-var-name id empty-wrap) r)))
+ out))
+ (new-mark))))
+
+(define chi-body
+ ;; Here we create the empty wrap and new environment with placeholder
+ ;; as required by chi-internal. On return we extend the environment
+ ;; to recognize the var-labels as lexical variables and build a letrec
+ ;; binding them to the var-vals which we expand here.
+ (lambda (body outer-form r w)
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
+ (body (map (lambda (x) (cons r (wrap x w))) body)))
+ (chi-internal ribcage outer-form body r
+ (lambda (exprs ids vars vals inits)
+ (when (null? exprs) (syntax-error outer-form "no expressions in body"))
+ (build-letrec no-source
+ vars
+ (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) vals)
+ (build-sequence no-source
+ (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) (append inits exprs)))))))))
+
+(define chi-internal
+ ;; In processing the forms of the body, we create a new, empty wrap.
+ ;; This wrap is augmented (destructively) each time we discover that
+ ;; the next form is a definition. This is done:
+ ;;
+ ;; (1) to allow the first nondefinition form to be a call to
+ ;; one of the defined ids even if the id previously denoted a
+ ;; definition keyword or keyword for a macro expanding into a
+ ;; definition;
+ ;; (2) to prevent subsequent definition forms (but unfortunately
+ ;; not earlier ones) and the first nondefinition form from
+ ;; confusing one of the bound identifiers for an auxiliary
+ ;; keyword; and
+ ;; (3) so that we do not need to restart the expansion of the
+ ;; first nondefinition form, which is problematic anyway
+ ;; since it might be the first element of a begin that we
+ ;; have just spliced into the body (meaning if we restarted,
+ ;; we'd really need to restart with the begin or the macro
+ ;; call that expanded into the begin, and we'd have to give
+ ;; up allowing (begin <defn>+ <expr>+), which is itself
+ ;; problematic since we don't know if a begin contains only
+ ;; definitions until we've expanded it).
+ ;;
+ ;; Before processing the body, we also create a new environment
+ ;; containing a placeholder for the bindings we will add later and
+ ;; associate this environment with each form. In processing a
+ ;; let-syntax or letrec-syntax, the associated environment may be
+ ;; augmented with local keyword bindings, so the environment may
+ ;; be different for different forms in the body. Once we have
+ ;; gathered up all of the definitions, we evaluate the transformer
+ ;; expressions and splice into r at the placeholder the new variable
+ ;; and keyword bindings. This allows let-syntax or letrec-syntax
+ ;; forms local to a portion or all of the body to shadow the
+ ;; definition bindings.
+ ;;
+ ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
+ ;; into the body.
+ ;;
+ ;; outer-form is fully wrapped w/source
+ (lambda (ribcage source-exp body r k)
+ (define return
+ (lambda (exprs ids vars vals inits)
+ (check-defined-ids source-exp ids)
+ (k exprs ids vars vals inits)))
+ (let parse ((body body) (ids '()) (vars '()) (vals '()) (inits '()))
+ (if (null? body)
+ (return body ids vars vals inits)
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda () (syntax-type e er empty-wrap no-source ribcage))
+ (lambda (type value e w s)
+ (case type
+ ((define-form)
+ (parse-define e w s
+ (lambda (id rhs w)
+ (let ((id (wrap id w)) (label (gen-label)))
+ (let ((var (gen-var id)))
+ (extend-ribcage! ribcage id label)
+ (extend-store! r label (make-binding 'lexical var))
+ (parse
+ (cdr body)
+ (cons id ids)
+ (cons var vars)
+ (cons (cons er (wrap rhs w)) vals)
+ inits))))))
+ ((define-syntax-form)
+ (parse-define-syntax e w s
+ (lambda (id rhs w)
+ (let ((id (wrap id w))
+ (label (gen-label))
+ (exp (chi rhs (transformer-env er) w)))
+ (extend-ribcage! ribcage id label)
+ (extend-store! r label (make-binding 'deferred exp))
+ (parse (cdr body) (cons id ids) vars vals inits)))))
+ ((module-form)
+ (let* ((*ribcage (make-empty-ribcage))
+ (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
+ (parse-module e w s *w
+ (lambda (id exports forms)
+ (chi-internal *ribcage (source-wrap e w s)
+ (map (lambda (d) (cons er d)) forms) r
+ (lambda (*body *ids *vars *vals *inits)
+ ; valid bound ids checked already by chi-internal
+ (check-module-exports source-exp (flatten-exports exports) *ids)
+ (let ((iface (make-trimmed-interface exports))
+ (vars (append *vars vars))
+ (vals (append *vals vals))
+ (inits (append inits *inits *body)))
+ (if id
+ (let ((label (gen-label)))
+ (extend-ribcage! ribcage id label)
+ (extend-store! r label (make-binding 'module iface))
+ (parse (cdr body) (cons id ids) vars vals inits))
+ (let ()
+ (do-import! iface ribcage)
+ (parse (cdr body) (cons iface ids) vars vals inits))))))))))
+ ((import-form)
+ (parse-import e w s
+ (lambda (mid)
+ (let ((mlabel (id-var-name mid empty-wrap)))
+ (let ((binding (lookup mlabel r)))
+ (case (car binding)
+ ((module)
+ (let ((iface (cdr binding)))
+ (when value (extend-ribcage-barrier! ribcage value))
+ (do-import! iface ribcage)
+ (parse (cdr body) (cons iface ids) vars vals inits)))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "import from unknown module"))))))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse (let f ((forms (syntax (e1 ...))))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids vars vals inits))))
+ ((local-syntax-form)
+ (chi-local-syntax value e er w s
+ (lambda (forms er w s)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids vars vals inits))))
+ (else ; found a non-definition
+ (return (cons (cons er (source-wrap e w s)) (cdr body))
+ ids vars vals inits))))))))))
+
+(define do-import!
+ (lambda (interface ribcage)
+ (let ((token (interface-token interface)))
+ (if token
+ (extend-ribcage-subst! ribcage token)
+ (vfor-each
+ (lambda (id)
+ (let ((label1 (id-var-name-loc id empty-wrap)))
+ (unless label1
+ (syntax-error id "exported identifier not visible"))
+ (extend-ribcage! ribcage id label1)))
+ (interface-exports interface))))))
+
+(define parse-module
+ (lambda (e w s *w k)
+ (define listify
+ (lambda (exports)
+ (if (null? exports)
+ '()
+ (cons (syntax-case (car exports) ()
+ ((ex ...) (listify (syntax (ex ...))))
+ (x (if (id? (syntax x))
+ (wrap (syntax x) *w)
+ (syntax-error (source-wrap e w s)
+ "invalid exports list in"))))
+ (listify (cdr exports))))))
+ (define return
+ (lambda (id exports forms)
+ (k id (listify exports) (map (lambda (x) (wrap x *w)) forms))))
+ (syntax-case e ()
+ ((_ (ex ...) form ...)
+ (return #f (syntax (ex ...)) (syntax (form ...))))
+ ((_ mid (ex ...) form ...)
+ (id? (syntax mid))
+ ; id receives old wrap so it won't be confused with id of same name
+ ; defined within the module
+ (return (wrap (syntax mid) w) (syntax (ex ...)) (syntax (form ...))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define parse-import
+ (lambda (e w s k)
+ (syntax-case e ()
+ ((_ mid)
+ (id? (syntax mid))
+ (k (wrap (syntax mid) w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define parse-define
+ (lambda (e w s k)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (k (syntax name) (syntax val) w))
+ ((_ (name . args) e1 e2 ...)
+ (and (id? (syntax name))
+ (valid-bound-ids? (lambda-var-list (syntax args))))
+ (k (wrap (syntax name) w)
+ (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
+ empty-wrap))
+ ((_ name)
+ (id? (syntax name))
+ (k (wrap (syntax name) w) (syntax (void)) empty-wrap))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define parse-define-syntax
+ (lambda (e w s k)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (k (syntax name) (syntax val) w))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define chi-lambda-clause
+ (lambda (e c r w k)
+ (syntax-case c ()
+ (((id ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (syntax-error e "invalid parameter list in")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (k new-vars
+ (chi-body (syntax (e1 e2 ...))
+ e
+ (extend-var-env* labels new-vars r)
+ (make-binding-wrap ids labels w)))))))
+ ((ids e1 e2 ...)
+ (let ((old-ids (lambda-var-list (syntax ids))))
+ (if (not (valid-bound-ids? old-ids))
+ (syntax-error e "invalid parameter list in")
+ (let ((labels (gen-labels old-ids))
+ (new-vars (map gen-var old-ids)))
+ (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
+ (if (null? ls1)
+ ls2
+ (f (cdr ls1) (cons (car ls1) ls2))))
+ (chi-body (syntax (e1 e2 ...))
+ e
+ (extend-var-env* labels new-vars r)
+ (make-binding-wrap old-ids labels w)))))))
+ (_ (syntax-error e)))))
+
+(define chi-local-syntax
+ (lambda (rec? e r w s k)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
+ (source-wrap e w s)
+ "keyword")
+ (let ((labels (gen-labels ids)))
+ (let ((new-w (make-binding-wrap ids labels w)))
+ (k (syntax (e1 e2 ...))
+ (extend-env*
+ labels
+ (let ((w (if rec? new-w w))
+ (trans-r (transformer-env r)))
+ (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
+ r)
+ new-w
+ s))))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define chi-void
+ (lambda ()
+ (build-application no-source (build-primref no-source 'void) '())))
+
+(define ellipsis?
+ (lambda (x)
+ (and (nonsymbol-id? x)
+ (literal-id=? x (syntax (... ...))))))
+
+;;; data
+
+;;; strips all annotations from potentially circular reader output
+
+(define strip-annotation
+ (lambda (x parent)
+ (cond
+ ((pair? x)
+ (let ((new (cons #f #f)))
+ (when parent (set-annotation-stripped! parent new))
+ (set-car! new (strip-annotation (car x) #f))
+ (set-cdr! new (strip-annotation (cdr x) #f))
+ new))
+ ((annotation? x)
+ (or (annotation-stripped x)
+ (strip-annotation (annotation-expression x) x)))
+ ((vector? x)
+ (let ((new (make-vector (vector-length x))))
+ (when parent (set-annotation-stripped! parent new))
+ (let loop ((i (- (vector-length x) 1)))
+ (unless (fx< i 0)
+ (vector-set! new i (strip-annotation (vector-ref x i) #f))
+ (loop (fx- i 1))))
+ new))
+ (else x))))
+
+;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
+;;; on an annotation, strips the annotation as well.
+;;; since only the head of a list is annotated by the reader, not each pair
+;;; in the spine, we also check for pairs whose cars are annotated in case
+;;; we've been passed the cdr of an annotated list
+
+(define strip*
+ (lambda (x w fn)
+ (if (top-marked? w)
+ (fn x)
+ (let f ((x x))
+ (cond
+ ((syntax-object? x)
+ (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x)))
+ x
+ (cons a d))))
+ ((vector? x)
+ (let ((old (vector->list x)))
+ (let ((new (map f old)))
+ (if (andmap eq? old new) x (list->vector new)))))
+ (else x))))))
+
+(define strip
+ (lambda (x w)
+ (strip* x w
+ (lambda (x)
+ (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
+ (strip-annotation x #f)
+ x)))))
+
+;;; lexical variables
+
+(define gen-var
+ (lambda (id)
+ (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (if (annotation? id)
+ (build-lexical-var (annotation-source id) (annotation-expression id))
+ (build-lexical-var no-source id)))))
+
+(define lambda-var-list
+ (lambda (vars)
+ (let lvl ((vars vars) (ls '()) (w empty-wrap))
+ (cond
+ ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
+ ((id? vars) (cons (wrap vars w) ls))
+ ((null? vars) ls)
+ ((syntax-object? vars)
+ (lvl (syntax-object-expression vars)
+ ls
+ (join-wraps w (syntax-object-wrap vars))))
+ ((annotation? vars)
+ (lvl (annotation-expression vars) ls w))
+ ; include anything else to be caught by subsequent error
+ ; checking
+ (else (cons vars ls))))))
+
+
+; must precede global-extends
+
+(set! $sc-put-cte
+ (lambda (id b)
+ (define put-token
+ (lambda (id token)
+ (define cons-id
+ (lambda (id x)
+ (if (not x) id (cons id x))))
+ (define weed
+ (lambda (id x)
+ (if (pair? x)
+ (if (bound-id=? (car x) id) ; could just check same-marks
+ (weed id (cdr x))
+ (cons-id (car x) (weed id (cdr x))))
+ (if (or (not x) (bound-id=? x id))
+ #f
+ x))))
+ (let ((sym (id-sym-name id)))
+ (let ((x (weed id (getprop sym token))))
+ (if (and (not x) (symbol? id))
+ ; don't pollute property list when all we have is a plain
+ ; top-level binding, since that's what's assumed anyway
+ (remprop sym token)
+ (putprop sym token (cons-id id x)))))))
+ (define sc-put-module
+ (lambda (exports token)
+ (vfor-each
+ (lambda (id) (put-token id token))
+ exports)))
+ (define (put-cte id binding)
+ ;; making assumption here that all macros should be visible to the user and that system
+ ;; globals don't come through here (primvars.ss sets up their properties)
+ (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
+ (putprop sym '*sc-expander* binding)))
+ (let ((binding (or (sanitize-binding b) (error 'define-syntax "invalid transformer ~s" b))))
+ (case (binding-type binding)
+ ((module)
+ (let ((iface (binding-value binding)))
+ (sc-put-module (interface-exports iface) (interface-token iface)))
+ (put-cte id binding))
+ ((do-import) ; fake binding: id is module id, binding-value is import token
+ (let ((token (binding-value b)))
+ (let ((b (lookup (id-var-name id empty-wrap) null-env)))
+ (case (binding-type b)
+ ((module)
+ (let ((iface (binding-value b)))
+ (unless (eq? (interface-token iface) token)
+ (syntax-error id "import mismatch for module"))
+ (sc-put-module (interface-exports iface) '*top*)))
+ (else (syntax-error id "import from unknown module"))))))
+ (else (put-cte id binding))))))
+
+
+;;; core transformers
+
+(global-extend 'local-syntax 'letrec-syntax #t)
+(global-extend 'local-syntax 'let-syntax #f)
+
+
+(global-extend 'core 'fluid-let-syntax
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? (syntax (var ...)))
+ (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
+ (for-each
+ (lambda (id n)
+ (case (binding-type (lookup n r))
+ ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
+ (syntax (var ...))
+ names)
+ (chi-body
+ (syntax (e1 e2 ...))
+ (source-wrap e w s)
+ (extend-env*
+ names
+ (let ((trans-r (transformer-env r)))
+ (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
+ r)
+ w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'core 'quote
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ e) (build-data s (strip (syntax e) w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis?)
+ (if (id? e)
+ (let ((label (id-var-name e empty-wrap)))
+ (let ((b (lookup label r)))
+ (if (eq? (binding-type b) 'syntax)
+ (call-with-values
+ (lambda ()
+ (let ((var.lev (binding-value b)))
+ (gen-ref src (car var.lev) (cdr var.lev) maps)))
+ (lambda (var maps) (values `(ref ,var) maps)))
+ (if (ellipsis? e)
+ (syntax-error src "misplaced ellipsis in syntax form")
+ (values `(quote ,e) maps)))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? (syntax dots))
+ (gen-syntax src (syntax e) r maps (lambda (x) #f)))
+ ((x dots . y)
+ ; this could be about a dozen lines of code, except that we
+ ; choose to handle (syntax (x ... ...)) forms
+ (ellipsis? (syntax dots))
+ (let f ((y (syntax y))
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src (syntax x) r
+ (cons '() maps) ellipsis?))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-error src
+ "extra ellipsis in syntax form")
+ (values (gen-map x (car maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? (syntax dots))
+ (f (syntax y)
+ (lambda (maps)
+ (call-with-values
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-error src
+ "extra ellipsis in syntax form")
+ (values (gen-mappend x (car maps))
+ (cdr maps))))))))
+ (_ (call-with-values
+ (lambda () (gen-syntax src y r maps ellipsis?))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps)
+ (values (gen-append x y) maps)))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
+ (lambda (y maps) (values (gen-cons x y) maps))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-error src "missing ellipsis in syntax form")
+ (call-with-values
+ (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var inner-var)
+ (car maps))
+ outer-maps)))))))))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ; identity map equivalence:
+ ; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((andmap
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ; eta map equivalence:
+ ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ (define gen-cons
+ (lambda (x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y)))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-vector
+ (lambda (x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x)))))
+
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
+ ((map) (let ((ls (map regen (cdr x))))
+ (build-application no-source
+ (if (fx= (length ls) 2)
+ (build-primref no-source 'map)
+ ; really need to do our own checking here
+ (build-primref no-source 2 'map)) ; require error check
+ ls)))
+ (else (build-application no-source
+ (build-primref no-source (car x))
+ (map regen (cdr x)))))))
+
+ (lambda (e r w s)
+ (let ((e (source-wrap e w s)))
+ (syntax-case e ()
+ ((_ x)
+ (call-with-values
+ (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-error e)))))))
+
+
+(global-extend 'core 'lambda
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ . c)
+ (chi-lambda-clause (source-wrap e w s) (syntax c) r w
+ (lambda (vars body) (build-lambda s vars body)))))))
+
+
+(global-extend 'core 'letrec
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
+ (source-wrap e w s) "bound variable")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((w (make-binding-wrap ids labels w))
+ (r (extend-var-env* labels new-vars r)))
+ (build-letrec s
+ new-vars
+ (map (lambda (x) (chi x r w)) (syntax (val ...)))
+ (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'core 'if
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional s
+ (chi (syntax test) r w)
+ (chi (syntax then) r w)
+ (chi-void)))
+ ((_ test then else)
+ (build-conditional s
+ (chi (syntax test) r w)
+ (chi (syntax then) r w)
+ (chi (syntax else) r w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+
+
+(global-extend 'set! 'set! '())
+
+(global-extend 'begin 'begin '())
+
+(global-extend 'module-key 'module '())
+(global-extend 'import 'import #f)
+(global-extend 'import 'import-only #t)
+
+(global-extend 'define 'define '())
+
+(global-extend 'define-syntax 'define-syntax '())
+
+(global-extend 'eval-when 'eval-when '())
+
+(global-extend 'core 'syntax-case
+ (let ()
+ (define convert-pattern
+ ; accepts pattern & keys
+ ; returns syntax-dispatch pattern & ids
+ (lambda (pattern keys)
+ (let cvt ((p pattern) (n 0) (ids '()))
+ (if (id? p)
+ (if (bound-id-member? p keys)
+ (values (vector 'free-id p) ids)
+ (values 'any (cons (cons p n) ids)))
+ (syntax-case p ()
+ ((x dots)
+ (ellipsis? (syntax dots))
+ (call-with-values
+ (lambda () (cvt (syntax x) (fx+ n 1) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any (vector 'each p))
+ ids))))
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt (syntax y) n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt (syntax x) n ids))
+ (lambda (x ids)
+ (values (cons x y) ids))))))
+ (() (values '() ids))
+ (#(x ...)
+ (call-with-values
+ (lambda () (cvt (syntax (x ...)) n ids))
+ (lambda (p ids) (values (vector 'vector p) ids))))
+ (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
+
+ (define build-dispatch-call
+ (lambda (pvars exp y r)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (build-application no-source
+ (build-primref no-source 'apply)
+ (list (build-lambda no-source new-vars
+ (chi exp
+ (extend-env*
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)))
+ y))))))
+
+ (define gen-clause
+ (lambda (x keys clauses r pat fender exp)
+ (call-with-values
+ (lambda () (convert-pattern pat keys))
+ (lambda (p pvars)
+ (cond
+ ((not (distinct-bound-ids? (map car pvars)))
+ (invalid-ids-error (map car pvars) pat "pattern variable"))
+ ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (syntax-error pat
+ "misplaced ellipsis in syntax-case pattern"))
+ (else
+ (let ((y (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable y
+ (build-application no-source
+ (build-lambda no-source (list y)
+ (let-syntax ((y (identifier-syntax
+ (build-lexical-reference 'value no-source y))))
+ (build-conditional no-source
+ (syntax-case fender ()
+ (#t y)
+ (_ (build-conditional no-source
+ y
+ (build-dispatch-call pvars fender y r)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r)
+ (gen-syntax-case x keys clauses r))))
+ (list (if (eq? p 'any)
+ (build-application no-source
+ (build-primref no-source 'list)
+ (list (build-lexical-reference no-source 'value x)))
+ (build-application no-source
+ (build-primref no-source '$syntax-dispatch)
+ (list (build-lexical-reference no-source 'value x)
+ (build-data no-source p)))))))))))))
+
+ (define gen-syntax-case
+ (lambda (x keys clauses r)
+ (if (null? clauses)
+ (build-application no-source
+ (build-primref no-source 'syntax-error)
+ (list (build-lexical-reference 'value no-source x)))
+ (syntax-case (car clauses) ()
+ ((pat exp)
+ (if (and (id? (syntax pat))
+ (not (bound-id-member? (syntax pat) keys))
+ (not (ellipsis? (syntax pat))))
+ (let ((label (gen-label))
+ (var (gen-var (syntax pat))))
+ (build-application no-source
+ (build-lambda no-source (list var)
+ (chi (syntax exp)
+ (extend-env label (make-binding 'syntax `(,var . 0)) r)
+ (make-binding-wrap (syntax (pat))
+ (list label) empty-wrap)))
+ (list (build-lexical-reference 'value no-source x))))
+ (gen-clause x keys (cdr clauses) r
+ (syntax pat) #t (syntax exp))))
+ ((pat fender exp)
+ (gen-clause x keys (cdr clauses) r
+ (syntax pat) (syntax fender) (syntax exp)))
+ (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+
+ (lambda (e r w s)
+ (let ((e (source-wrap e w s)))
+ (syntax-case e ()
+ ((_ val (key ...) m ...)
+ (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
+ (syntax (key ...)))
+ (let ((x (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable x
+ (build-application s
+ (build-lambda no-source (list x)
+ (gen-syntax-case x
+ (syntax (key ...)) (syntax (m ...))
+ r))
+ (list (chi (syntax val) r empty-wrap))))
+ (syntax-error e "invalid literals list in"))))))))
+
+;;; The portable sc-expand seeds chi-top's mode m with 'e (for
+;;; evaluating) and esew (which stands for "eval syntax expanders
+;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
+;;; if we are compiling a file, and esew is set to
+;;; (eval-syntactic-expanders-when), which defaults to the list
+;;; '(compile load eval). This means that, by default, top-level
+;;; syntactic definitions are evaluated immediately after they are
+;;; expanded, and the expanded definitions are also residualized into
+;;; the object file if we are compiling a file.
+(set! sc-expand
+ (let ((m 'e) (esew '(eval))
+ (user-ribcage
+ (let ((ribcage (make-empty-ribcage)))
+ (extend-ribcage-subst! ribcage '*top*)
+ ribcage)))
+ (let ((user-top-wrap
+ (make-wrap (wrap-marks top-wrap)
+ (cons user-ribcage (wrap-subst top-wrap)))))
+ (lambda (x)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (chi-top x null-env user-top-wrap m esew user-ribcage))))))
+
+(set! identifier?
+ (lambda (x)
+ (nonsymbol-id? x)))
+
+(set! datum->syntax-object
+ (lambda (id datum)
+ (arg-check nonsymbol-id? id 'datum->syntax-object)
+ (make-syntax-object datum (syntax-object-wrap id))))
+
+(set! syntax-object->datum
+ ; accepts any object, since syntax objects may consist partially
+ ; or entirely of unwrapped, nonsymbolic data
+ (lambda (x)
+ (strip x empty-wrap)))
+
+(set! generate-temporaries
+ (lambda (ls)
+ (arg-check list? ls 'generate-temporaries)
+ (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
+
+(set! free-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'free-identifier=?)
+ (arg-check nonsymbol-id? y 'free-identifier=?)
+ (free-id=? x y)))
+
+(set! bound-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'bound-identifier=?)
+ (arg-check nonsymbol-id? y 'bound-identifier=?)
+ (bound-id=? x y)))
+
+
+(set! syntax-error
+ (lambda (object . messages)
+ (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
+ (let ((message (if (null? messages)
+ "invalid syntax"
+ (apply string-append messages))))
+ (error-hook #f message (strip object empty-wrap)))))
+
+;;; syntax-dispatch expects an expression and a pattern. If the expression
+;;; matches the pattern a list of the matching expressions for each
+;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
+;;; not work on r4rs implementations that violate the ieee requirement
+;;; that #f and () be distinct.)
+
+;;; The expression is matched with the pattern as follows:
+
+;;; pattern: matches:
+;;; () empty list
+;;; any anything
+;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
+;;; each-any (any*)
+;;; #(free-id <key>) <key> with free-identifier=?
+;;; #(each <pattern>) (<pattern>*)
+;;; #(vector <pattern>) (list->vector <pattern>)
+;;; #(atom <object>) <object> with "equal?"
+
+;;; Vector cops out to pair under assumption that vectors are rare. If
+;;; not, should convert to:
+;;; #(vector <pattern>*) #(<pattern>*)
+
+(let ()
+
+(define match-each
+ (lambda (e p w)
+ (cond
+ ((annotation? e)
+ (match-each (annotation-expression e) p w))
+ ((pair? e)
+ (let ((first (match (car e) p w '())))
+ (and first
+ (let ((rest (match-each (cdr e) p w)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))))
+ (else #f))))
+
+(define match-each-any
+ (lambda (e w)
+ (cond
+ ((annotation? e)
+ (match-each-any (annotation-expression e) w))
+ ((pair? e)
+ (let ((l (match-each-any (cdr e) w)))
+ (and l (cons (wrap (car e) w) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))))
+ (else #f))))
+
+(define match-empty
+ (lambda (p r)
+ (cond
+ ((null? p) r)
+ ((eq? p 'any) (cons '() r))
+ ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+ ((eq? p 'each-any) (cons '() r))
+ (else
+ (case (vector-ref p 0)
+ ((each) (match-empty (vector-ref p 1) r))
+ ((free-id atom) r)
+ ((vector) (match-empty (vector-ref p 1) r)))))))
+
+(define match*
+ (lambda (e p w r)
+ (cond
+ ((null? p) (and (null? e) r))
+ ((pair? p)
+ (and (pair? e) (match (car e) (car p) w
+ (match (cdr e) (cdr p) w r))))
+ ((eq? p 'each-any)
+ (let ((l (match-each-any e w))) (and l (cons l r))))
+ (else
+ (case (vector-ref p 0)
+ ((each)
+ (if (null? e)
+ (match-empty (vector-ref p 1) r)
+ (let ((l (match-each e (vector-ref p 1) w)))
+ (and l
+ (let collect ((l l))
+ (if (null? (car l))
+ r
+ (cons (map car l) (collect (map cdr l)))))))))
+ ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
+ ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
+ ((vector)
+ (and (vector? e)
+ (match (vector->list e) (vector-ref p 1) w r))))))))
+
+(define match
+ (lambda (e p w r)
+ (cond
+ ((not r) #f)
+ ((eq? p 'any) (cons (wrap e w) r))
+ ((syntax-object? e)
+ (match*
+ (unannotate (syntax-object-expression e))
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r))
+ (else (match* (unannotate e) p w r)))))
+
+(set! $syntax-dispatch
+ (lambda (e p)
+ (cond
+ ((eq? p 'any) (list e))
+ ((syntax-object? e)
+ (match* (unannotate (syntax-object-expression e))
+ p (syntax-object-wrap e) '()))
+ (else (match* (unannotate e) p empty-wrap '())))))
+))
+
+
+(define-syntax with-syntax
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () e1 e2 ...)
+ (syntax (begin e1 e2 ...)))
+ ((_ ((out in)) e1 e2 ...)
+ (syntax (syntax-case in () (out (begin e1 e2 ...)))))
+ ((_ ((out in) ...) e1 e2 ...)
+ (syntax (syntax-case (list in ...) ()
+ ((out ...) (begin e1 e2 ...))))))))
+
+(define-syntax syntax-rules
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k ...) ((keyword . pattern) template) ...)
+ (syntax (lambda (x)
+ (syntax-case x (k ...)
+ ((dummy . pattern) (syntax template))
+ ...)))))))
+
+(define-syntax or
+ (lambda (x)
+ (syntax-case x ()
+ ((_) (syntax #f))
+ ((_ e) (syntax e))
+ ((_ e1 e2 e3 ...)
+ (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
+
+(define-syntax and
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
+ ((_ e) (syntax e))
+ ((_) (syntax #t)))))
+
+(define-syntax let
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (x ...)))
+ (syntax ((lambda (x ...) e1 e2 ...) v ...)))
+ ((_ f ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (f x ...)))
+ (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
+ v ...))))))
+
+(define-syntax let*
+ (lambda (x)
+ (syntax-case x ()
+ ((let* ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (x ...)))
+ (let f ((bindings (syntax ((x v) ...))))
+ (if (null? bindings)
+ (syntax (let () e1 e2 ...))
+ (with-syntax ((body (f (cdr bindings)))
+ (binding (car bindings)))
+ (syntax (let (binding) body)))))))))
+
+(define-syntax cond
+ (lambda (x)
+ (syntax-case x ()
+ ((_ m1 m2 ...)
+ (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
+ (if (null? clauses)
+ (syntax-case clause (else =>)
+ ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
+ ((e0) (syntax (let ((t e0)) (if t t))))
+ ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
+ ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
+ (_ (syntax-error x)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else =>)
+ ((e0) (syntax (let ((t e0)) (if t t rest))))
+ ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
+ ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
+ (_ (syntax-error x))))))))))
+
+(define-syntax do
+ (lambda (orig-x)
+ (syntax-case orig-x ()
+ ((_ ((var init . step) ...) (e0 e1 ...) c ...)
+ (with-syntax (((step ...)
+ (map (lambda (v s)
+ (syntax-case s ()
+ (() v)
+ ((e) (syntax e))
+ (_ (syntax-error orig-x))))
+ (syntax (var ...))
+ (syntax (step ...)))))
+ (syntax-case (syntax (e1 ...)) ()
+ (() (syntax (let doloop ((var init) ...)
+ (if (not e0)
+ (begin c ... (doloop step ...))))))
+ ((e1 e2 ...)
+ (syntax (let doloop ((var init) ...)
+ (if e0
+ (begin e1 e2 ...)
+ (begin c ... (doloop step ...))))))))))))
+
+(define-syntax quasiquote
+ (letrec
+ ; these are here because syntax-case uses literal-identifier=?,
+ ; and we want the more precise free-identifier=?
+ ((isquote? (lambda (x)
+ (and (identifier? x)
+ (free-identifier=? x (syntax quote)))))
+ (islist? (lambda (x)
+ (and (identifier? x)
+ (free-identifier=? x (syntax list)))))
+ (iscons? (lambda (x)
+ (and (identifier? x)
+ (free-identifier=? x (syntax cons)))))
+ (quote-nil? (lambda (x)
+ (syntax-case x ()
+ ((quote? ()) (isquote? (syntax quote?)))
+ (_ #f))))
+ (quasilist*
+ (lambda (x y)
+ (let f ((x x))
+ (if (null? x)
+ y
+ (quasicons (car x) (f (cdr x)))))))
+ (quasicons
+ (lambda (x y)
+ (with-syntax ((x x) (y y))
+ (syntax-case (syntax y) ()
+ ((quote? dy)
+ (isquote? (syntax quote?))
+ (syntax-case (syntax x) ()
+ ((quote? dx)
+ (isquote? (syntax quote?))
+ (syntax (quote (dx . dy))))
+ (_ (if (null? (syntax dy))
+ (syntax (list x))
+ (syntax (cons x y))))))
+ ((listp . stuff)
+ (islist? (syntax listp))
+ (syntax (list x . stuff)))
+ (else (syntax (cons x y)))))))
+ (quasiappend
+ (lambda (x y)
+ (let ((ls (let f ((x x))
+ (if (null? x)
+ (if (quote-nil? y)
+ '()
+ (list y))
+ (if (quote-nil? (car x))
+ (f (cdr x))
+ (cons (car x) (f (cdr x))))))))
+ (cond
+ ((null? ls) (syntax (quote ())))
+ ((null? (cdr ls)) (car ls))
+ (else (with-syntax (((p ...) ls))
+ (syntax (append p ...))))))))
+ (quasivector
+ (lambda (x)
+ (with-syntax ((pat-x x))
+ (syntax-case (syntax pat-x) ()
+ ((quote? (x ...))
+ (isquote? (syntax quote?))
+ (syntax (quote #(x ...))))
+ (_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls))))
+ (syntax-case x ()
+ ((quote? (x ...))
+ (isquote? (syntax quote?))
+ (k (syntax ((quote x) ...))))
+ ((listp x ...)
+ (islist? (syntax listp))
+ (k (syntax (x ...))))
+ ((cons? x y)
+ (iscons? (syntax cons?))
+ (f (syntax y) (lambda (ls) (k (cons (syntax x) ls)))))
+ (else
+ (syntax (list->vector pat-x))))))))))
+ (quasi
+ (lambda (p lev)
+ (syntax-case p (unquote unquote-splicing quasiquote)
+ ((unquote p)
+ (if (= lev 0)
+ (syntax p)
+ (quasicons (syntax (quote unquote))
+ (quasi (syntax (p)) (- lev 1)))))
+ (((unquote p ...) . q)
+ (if (= lev 0)
+ (quasilist* (syntax (p ...)) (quasi (syntax q) lev))
+ (quasicons (quasicons (syntax (quote unquote))
+ (quasi (syntax (p ...)) (- lev 1)))
+ (quasi (syntax q) lev))))
+ (((unquote-splicing p ...) . q)
+ (if (= lev 0)
+ (quasiappend (syntax (p ...)) (quasi (syntax q) lev))
+ (quasicons (quasicons (syntax (quote unquote-splicing))
+ (quasi (syntax (p ...)) (- lev 1)))
+ (quasi (syntax q) lev))))
+ ((quasiquote p)
+ (quasicons (syntax (quote quasiquote))
+ (quasi (syntax (p)) (+ lev 1))))
+ ((p . q)
+ (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
+ (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
+ (p (syntax (quote p)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e) (quasi (syntax e) 0))))))
+
+(define-syntax include
+ (lambda (x)
+ (define read-file
+ (lambda (fn k)
+ (let ((p (open-input-file fn)))
+ (let f ()
+ (let ((x (read p)))
+ (if (eof-object? x)
+ (begin (close-input-port p) '())
+ (cons (datum->syntax-object k x) (f))))))))
+ (syntax-case x ()
+ ((k filename)
+ (let ((fn (syntax-object->datum (syntax filename))))
+ (with-syntax (((exp ...) (read-file fn (syntax k))))
+ (syntax (begin exp ...))))))))
+
+(define-syntax unquote
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e ...)
+ (syntax-error x
+ "expression not valid outside of quasiquote")))))
+
+(define-syntax unquote-splicing
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e ...)
+ (syntax-error x
+ "expression not valid outside of quasiquote")))))
+
+(define-syntax case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e m1 m2 ...)
+ (with-syntax
+ ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
+ (if (null? clauses)
+ (syntax-case clause (else)
+ ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
+ (((k ...) e1 e2 ...)
+ (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
+ (_ (syntax-error x)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else)
+ (((k ...) e1 e2 ...)
+ (syntax (if (memv t '(k ...))
+ (begin e1 e2 ...)
+ rest)))
+ (_ (syntax-error x))))))))
+ (syntax (let ((t e)) body)))))))
+
+(define-syntax identifier-syntax
+ (lambda (x)
+ (syntax-case x (set!)
+ ((_ e)
+ (syntax
+ (lambda (x)
+ (syntax-case x ()
+ (id
+ (identifier? (syntax id))
+ (syntax e))
+ ((_ x (... ...))
+ (syntax (e x (... ...))))))))
+ ((_ (id exp1) ((set! var val) exp2))
+ (and (identifier? (syntax id)) (identifier? (syntax var)))
+ (syntax
+ (cons 'macro!
+ (lambda (x)
+ (syntax-case x (set!)
+ ((set! var val) (syntax exp2))
+ ((id x (... ...)) (syntax (exp1 x (... ...))))
+ (id (identifier? (syntax id)) (syntax exp1))))))))))
+
--- /dev/null
+;;; Guile R5RS
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language r5rs spec)
+ :use-module (system base language)
+ :use-module (language r5rs expand)
+ :use-module (language r5rs translate)
+ :export (r5rs))
+
+\f
+;;;
+;;; Translator
+;;;
+
+(define (translate x) (if (pair? x) (translate-pair x) x))
+
+(define (translate-pair x)
+ (let ((head (car x)) (rest (cdr x)))
+ (case head
+ ((quote) (cons '@quote rest))
+ ((define set! if and or begin)
+ (cons (symbol-append '@ head) (map translate rest)))
+ ((let let* letrec)
+ (cons* (symbol-append '@ head)
+ (map (lambda (b) (cons (car b) (map translate (cdr b))))
+ (car rest))
+ (map translate (cdr rest))))
+ ((lambda)
+ (cons* '@lambda (car rest) (map translate (cdr rest))))
+ (else
+ (cons (translate head) (map translate rest))))))
+
+\f
+;;;
+;;; Language definition
+;;;
+
+(define-language r5rs
+ :title "Standard Scheme (R5RS + syntax-case)"
+ :version "0.3"
+ :reader read
+ :expander expand
+ :translator translate
+ :printer write
+;; :environment (global-ref 'Language::R5RS::core)
+ )
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+SOURCES = translate.scm spec.scm
+modpath = language/scheme
+include $(top_srcdir)/guilec.mk
--- /dev/null
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme spec)
+ :use-module (language scheme translate)
+ :use-module (system base language)
+ :export (scheme))
+
+;;;
+;;; Reader
+;;;
+
+(read-enable 'positions)
+
+(define (read-file port)
+ (do ((x (read port) (read port))
+ (l '() (cons x l)))
+ ((eof-object? x)
+ (cons 'begin (reverse! l)))))
+
+;;;
+;;; Language definition
+;;;
+
+(define-language scheme
+ :title "Guile Scheme"
+ :version "0.5"
+ :reader read
+ :read-file read-file
+ :translator translate
+ :printer write
+ )
--- /dev/null
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme translate)
+ :use-module (system base pmatch)
+ :use-module (system base language)
+ :use-module (system il ghil)
+ :use-module (system il inline)
+ :use-module (ice-9 receive)
+ :use-module (srfi srfi-39)
+ :use-module ((system base compile) :select (syntax-error))
+ :export (translate))
+
+
+(define (translate x e)
+ (call-with-ghil-environment (make-ghil-mod e) '()
+ (lambda (env vars)
+ (make-ghil-lambda env #f vars #f '() (trans env (location x) x)))))
+
+\f
+;;;
+;;; Translator
+;;;
+
+(define %forbidden-primitives
+ ;; Guile's `procedure->macro' family is evil because it crosses the
+ ;; compilation boundary. One solution might be to evaluate calls to
+ ;; `procedure->memoizing-macro' at compilation time, but it may be more
+ ;; compicated than that.
+ '(procedure->syntax procedure->macro procedure->memoizing-macro))
+
+(define (lookup-transformer e head retrans)
+ (let* ((mod (ghil-mod-module (ghil-env-mod e)))
+ (val (and (symbol? head)
+ (and=> (module-variable mod head)
+ (lambda (var)
+ ;; unbound vars can happen if the module
+ ;; definition forward-declared them
+ (and (variable-bound? var) (variable-ref var)))))))
+ (cond
+ ((or (primitive-macro? val) (eq? val eval-case))
+ (or (assq-ref primitive-syntax-table head)
+ (syntax-error #f "unhandled primitive macro" head)))
+
+ ((defmacro? val)
+ (lambda (env loc exp)
+ (retrans (apply (defmacro-transformer val) (cdr exp)))))
+
+ ((and (macro? val) (eq? (macro-name val) 'sc-macro))
+ ;; syncase!
+ (let* ((the-syncase-module (resolve-module '(ice-9 syncase)))
+ (eec (module-ref the-syncase-module 'expansion-eval-closure))
+ (sc-expand3 (module-ref the-syncase-module 'sc-expand3)))
+ (lambda (env loc exp)
+ (retrans
+ (with-fluids ((eec (module-eval-closure mod)))
+ (sc-expand3 exp 'c '(compile load eval)))))))
+
+ ((macro? val)
+ (syntax-error #f "unknown kind of macro" head))
+
+ (else #f))))
+
+(define (trans e l x)
+ (define (retrans x) (trans e (location x) x))
+ (cond ((pair? x)
+ (let ((head (car x)) (tail (cdr x)))
+ (cond
+ ((lookup-transformer e head retrans)
+ => (lambda (t) (t e l x)))
+
+ ;; FIXME: lexical/module overrides of forbidden primitives
+ ((memq head %forbidden-primitives)
+ (syntax-error l (format #f "`~a' is forbidden" head)
+ (cons head tail)))
+
+ (else
+ (let ((tail (map retrans tail)))
+ (or (and (symbol? head)
+ (try-inline-with-env e l (cons head tail)))
+ (make-ghil-call e l (retrans head) tail)))))))
+
+ ((symbol? x)
+ (make-ghil-ref e l (ghil-lookup e x)))
+
+ ;; fixme: non-self-quoting objects like #<foo>
+ (else
+ (make-ghil-quote e l #:obj x))))
+
+(define (valid-bindings? bindings . it-is-for-do)
+ (define (valid-binding? b)
+ (pmatch b
+ ((,sym ,var) (guard (symbol? sym)) #t)
+ ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
+ (else #f)))
+ (and (list? bindings) (and-map valid-binding? bindings)))
+
+(define-macro (make-pmatch-transformers env loc retranslate . body)
+ (define exp (gensym))
+ (define (make1 clause)
+ (let ((sym (car clause))
+ (clauses (cdr clause)))
+ `(cons ',sym
+ (lambda (,env ,loc ,exp)
+ (define (,retranslate x) (trans ,env (location x) x))
+ (pmatch (cdr ,exp)
+ ,@clauses
+ (else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
+ `(list ,@(map make1 body)))
+
+(define *the-compile-toplevel-symbol* 'compile-toplevel)
+
+(define primitive-syntax-table
+ (make-pmatch-transformers
+ e l retrans
+ (quote
+ ;; (quote OBJ)
+ ((,obj) (make-ghil-quote e l obj)))
+
+ (quasiquote
+ ;; (quasiquote OBJ)
+ ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj))))
+
+ (define
+ ;; (define NAME VAL)
+ ((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e))
+ (make-ghil-define e l (ghil-define (ghil-env-parent e) name)
+ (retrans val)))
+ ;; (define (NAME FORMALS...) BODY...)
+ (((,name . ,formals) . ,body) (guard (symbol? name))
+ ;; -> (define NAME (lambda FORMALS BODY...))
+ (retrans `(define ,name (lambda ,formals ,@body)))))
+
+ (set!
+ ;; (set! NAME VAL)
+ ((,name ,val) (guard (symbol? name))
+ (make-ghil-set e l (ghil-lookup e name) (retrans val)))
+
+ ;; (set! (NAME ARGS...) VAL)
+ (((,name . ,args) ,val) (guard (symbol? name))
+ ;; -> ((setter NAME) ARGS... VAL)
+ (retrans `((setter ,name) . (,@args ,val)))))
+
+ (if
+ ;; (if TEST THEN [ELSE])
+ ((,test ,then)
+ (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
+ ((,test ,then ,else)
+ (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
+
+ (and
+ ;; (and EXPS...)
+ (,tail (make-ghil-and e l (map retrans tail))))
+
+ (or
+ ;; (or EXPS...)
+ (,tail (make-ghil-or e l (map retrans tail))))
+
+ (begin
+ ;; (begin EXPS...)
+ (,tail (make-ghil-begin e l (map retrans tail))))
+
+ (let
+ ;; (let NAME ((SYM VAL) ...) BODY...)
+ ((,name ,bindings . ,body) (guard (symbol? name)
+ (valid-bindings? bindings))
+ ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
+ (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
+ (,name ,@(map cadr bindings)))))
+
+ ;; (let () BODY...)
+ ((() . ,body)
+ ;; Note: this differs from `begin'
+ (make-ghil-begin e l (list (trans-body e l body))))
+
+ ;; (let ((SYM VAL) ...) BODY...)
+ ((,bindings . ,body) (guard (valid-bindings? bindings))
+ (let ((vals (map retrans (map cadr bindings))))
+ (call-with-ghil-bindings e (map car bindings)
+ (lambda (vars)
+ (make-ghil-bind e l vars vals (trans-body e l body)))))))
+
+ (let*
+ ;; (let* ((SYM VAL) ...) BODY...)
+ ((() . ,body)
+ (retrans `(let () ,@body)))
+ ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
+ (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
+
+ (letrec
+ ;; (letrec ((SYM VAL) ...) BODY...)
+ ((,bindings . ,body) (guard (valid-bindings? bindings))
+ (call-with-ghil-bindings e (map car bindings)
+ (lambda (vars)
+ (let ((vals (map retrans (map cadr bindings))))
+ (make-ghil-bind e l vars vals (trans-body e l body)))))))
+
+ (cond
+ ;; (cond (CLAUSE BODY...) ...)
+ (() (retrans '(begin)))
+ (((else . ,body)) (retrans `(begin ,@body)))
+ (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
+ (((,test => ,proc) . ,rest)
+ ;; FIXME hygiene!
+ (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
+ (((,test . ,body) . ,rest)
+ (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
+
+ (case
+ ;; (case EXP ((KEY...) BODY...) ...)
+ ((,exp . ,clauses)
+ (retrans
+ ;; FIXME hygiene!
+ `(let ((_t ,exp))
+ ,(let loop ((ls clauses))
+ (cond ((null? ls) '(begin))
+ ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
+ (else `(if (memv _t ',(caar ls))
+ (begin ,@(cdar ls))
+ ,(loop (cdr ls))))))))))
+
+ (do
+ ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
+ ((,bindings (,test . ,result) . ,body)
+ (let ((sym (map car bindings))
+ (val (map cadr bindings))
+ (update (map cddr bindings)))
+ (define (next s x) (if (pair? x) (car x) s))
+ (retrans
+ ;; FIXME hygiene!
+ `(letrec ((_l (lambda ,sym
+ (if ,test
+ (begin ,@result)
+ (begin ,@body
+ (_l ,@(map next sym update)))))))
+ (_l ,@val))))))
+
+ (lambda
+ ;; (lambda FORMALS BODY...)
+ ((,formals . ,body)
+ (receive (syms rest) (parse-formals formals)
+ (call-with-ghil-environment e syms
+ (lambda (env vars)
+ (receive (meta body) (parse-lambda-meta body)
+ (make-ghil-lambda env l vars rest meta
+ (trans-body env l body))))))))
+
+ (eval-case
+ (,clauses
+ (retrans
+ `(begin
+ ,@(let ((toplevel? (ghil-env-toplevel? e)))
+ (let loop ((seen '()) (in clauses) (runtime '()))
+ (cond
+ ((null? in) runtime)
+ (else
+ (pmatch (car in)
+ ((else . ,body)
+ (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
+ (primitive-eval `(begin ,@body)))
+ (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
+ runtime
+ body))
+ ((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
+ (for-each (lambda (k)
+ (if (memq k seen)
+ (syntax-error l "eval-case condition seen twice" k)))
+ keys)
+ (if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
+ (primitive-eval `(begin ,@body)))
+ (loop (append keys seen)
+ (cdr in)
+ (if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
+ (append runtime body)
+ runtime)))
+ (else (syntax-error l "bad eval-case clause" (car in))))))))))))))
+
+(define (trans-quasiquote e l x)
+ (cond ((not (pair? x)) x)
+ ((memq (car x) '(unquote unquote-splicing))
+ (let ((l (location x)))
+ (pmatch (cdr x)
+ ((,obj)
+ (if (eq? (car x) 'unquote)
+ (make-ghil-unquote e l (trans e l obj))
+ (make-ghil-unquote-splicing e l (trans e l obj))))
+ (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+ (else (cons (trans-quasiquote e l (car x))
+ (trans-quasiquote e l (cdr x))))))
+
+(define (trans-body e l body)
+ (define (define->binding df)
+ (pmatch (cdr df)
+ ((,name ,val) (guard (symbol? name)) (list name val))
+ (((,name . ,formals) . ,body) (guard (symbol? name))
+ (list name `(lambda ,formals ,@body)))
+ (else (syntax-error (location df) "bad define" df))))
+ ;; main
+ (let loop ((ls body) (ds '()))
+ (pmatch ls
+ (() (syntax-error l "bad body" body))
+ (((define . _) . _)
+ (loop (cdr ls) (cons (car ls) ds)))
+ (else
+ (if (null? ds)
+ (trans e l `(begin ,@ls))
+ (trans e l `(letrec ,(map define->binding ds) ,@ls)))))))
+
+(define (parse-formals formals)
+ (cond
+ ;; (lambda x ...)
+ ((symbol? formals) (values (list formals) #t))
+ ;; (lambda (x y z) ...)
+ ((list? formals) (values formals #f))
+ ;; (lambda (x y . z) ...)
+ ((pair? formals)
+ (let loop ((l formals) (v '()))
+ (if (pair? l)
+ (loop (cdr l) (cons (car l) v))
+ (values (reverse! (cons l v)) #t))))
+ (else (syntax-error (location formals) "bad formals" formals))))
+
+(define (parse-lambda-meta body)
+ (cond ((or (null? body) (null? (cdr body))) (values '() body))
+ ((string? (car body))
+ (values `((documentation . ,(car body))) (cdr body)))
+ (else (values '() body))))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ (vector (assq-ref props 'line)
+ (assq-ref props 'column)
+ (assq-ref props 'filename))))))
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+SUBDIRS = base il vm repl
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+SOURCES = pmatch.scm syntax.scm compile.scm language.scm
+modpath = system/base
+include $(top_srcdir)/guilec.mk
--- /dev/null
+;;; High-level compiler interface
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system base compile)
+ :use-syntax (system base syntax)
+ :use-module (system base language)
+ :use-module (system il compile)
+ :use-module (system il glil)
+ :use-module (system vm objcode)
+ :use-module (system vm vm) ;; for compile-time evaluation
+ :use-module (system vm assemble)
+ :use-module (ice-9 regex)
+ :export (syntax-error compile-file load-source-file load-file
+ compiled-file-name
+ scheme-eval read-file-in compile-in
+ load/compile))
+
+;;;
+;;; Compiler environment
+;;;
+
+(define (syntax-error loc msg exp)
+ (throw 'syntax-error loc msg exp))
+
+(define-macro (call-with-compile-error-catch thunk)
+ `(catch 'syntax-error
+ ,thunk
+ (lambda (key loc msg exp)
+ (if (pair? loc)
+ (format #t "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
+ (format #t "unknown location: ~A: ~A~%" msg exp)))))
+
+(export-syntax call-with-compile-error-catch)
+
+
+\f
+;;;
+;;; Compiler
+;;;
+
+(define (scheme) (lookup-language 'scheme))
+
+(define (call-with-output-file/atomic filename proc)
+ (let* ((template (string-append filename ".XXXXXX"))
+ (tmp (mkstemp! template)))
+ (catch #t
+ (lambda ()
+ (with-output-to-port tmp
+ (lambda () (proc (current-output-port))))
+ (rename-file template filename))
+ (lambda args
+ (delete-file template)
+ (apply throw args)))))
+
+(define (compile-file file . opts)
+ (let ((comp (compiled-file-name file))
+ (scheme (scheme)))
+ (catch 'nothing-at-all
+ (lambda ()
+ (call-with-compile-error-catch
+ (lambda ()
+ (call-with-output-file/atomic comp
+ (lambda (port)
+ (let* ((source (read-file-in file scheme))
+ (objcode (apply compile-in source (current-module)
+ scheme opts)))
+ (if (memq :c opts)
+ (pprint-glil objcode port)
+ (uniform-vector-write (objcode->u8vector objcode) port)))))
+ (format #t "wrote `~A'\n" comp))))
+ (lambda (key . args)
+ (format #t "ERROR: during compilation of ~A:\n" file)
+ (display "ERROR: ")
+ (apply format #t (cadr args) (caddr args))
+ (newline)
+ (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
+ (delete-file comp)))))
+
+; (let ((c-f compile-file))
+; ;; XXX: Debugging output
+; (set! compile-file
+; (lambda (file . opts)
+; (format #t "compile-file: ~a ~a~%" file opts)
+; (let ((result (apply c-f (cons file opts))))
+; (format #t "compile-file: returned ~a~%" result)
+; result))))
+
+(define (load-source-file file . opts)
+ (let ((source (read-file-in file (scheme))))
+ (apply compile-in source (current-module) (scheme) opts)))
+
+(define (load-file file . opts)
+ (let ((comp (compiled-file-name file)))
+ (if (file-exists? comp)
+ (load-objcode comp)
+ (apply load-source-file file opts))))
+
+(define (compiled-file-name file)
+ (let ((base (basename file)))
+ (let ((m (string-match "\\.scm$" base)))
+ (string-append (if m (match:prefix m) base) ".go"))))
+
+(define (scheme-eval x e)
+ (vm-load (the-vm) (compile-in x e (scheme))))
+
+\f
+;;;
+;;; Scheme compiler interface
+;;;
+
+(define (read-file-in file lang)
+ (call-with-input-file file (language-read-file lang)))
+
+(define (compile-in x e lang . opts)
+ (save-module-excursion
+ (lambda ()
+ (catch 'result
+ (lambda ()
+ ;; expand
+ (set! x ((language-expander lang) x e))
+ (if (memq :e opts) (throw 'result x))
+ ;; translate
+ (set! x ((language-translator lang) x e))
+ (if (memq :t opts) (throw 'result x))
+ ;; compile
+ (set! x (apply compile x e opts))
+ (if (memq :c opts) (throw 'result x))
+ ;; assemble
+ (apply assemble x e opts))
+ (lambda (key val) val)))))
+
+;;;
+;;;
+;;;
+
+(define (compile-and-load file . opts)
+ (let ((comp (object-file-name file)))
+ (if (or (not (file-exists? comp))
+ (> (stat:mtime (stat file)) (stat:mtime (stat comp))))
+ (compile-file file))
+ (load-compiled-file comp)))
+
+(define (load/compile file . opts)
+ (let* ((file (file-full-name file))
+ (compiled (object-file-name file)))
+ (if (or (not (file-exists? compiled))
+ (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
+ (apply compile-file file #f opts))
+ (if (memq #:b opts)
+ (apply vm-trace (the-vm) (load-objcode compiled) opts)
+ ((the-vm) (load-objcode compiled)))))
+
+(define (file-full-name filename)
+ (let* ((port (current-load-port))
+ (oldname (and port (port-filename port))))
+ (if (and oldname
+ (> (string-length filename) 0)
+ (not (char=? (string-ref filename 0) #\/))
+ (not (string=? (dirname oldname) ".")))
+ (string-append (dirname oldname) "/" filename)
+ filename)))
--- /dev/null
+;;; Multi-language support
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system base language)
+ :use-syntax (system base syntax)
+ :export (define-language lookup-language make-language
+ language-name language-title language-version language-reader
+ language-printer language-read-file language-expander
+ language-translator language-evaluator language-environment))
+
+\f
+;;;
+;;; Language class
+;;;
+
+(define-record (<language> name title version reader printer read-file
+ (expander (lambda (x e) x))
+ (translator (lambda (x e) x))
+ (evaluator #f)
+ (environment #f)
+ ))
+
+(define-macro (define-language name . spec)
+ `(define ,name (make-language :name ',name ,@spec)))
+
+(define (lookup-language name)
+ (let ((m (resolve-module `(language ,name spec))))
+ (if (module-bound? m name)
+ (module-ref m name)
+ (error "no such language" name))))
--- /dev/null
+(define-module (system base pmatch)
+ #:use-module (ice-9 syncase)
+ #:export (pmatch ppat))
+;; FIXME: shouldn't have to export ppat...
+
+;; Originally written by Oleg Kiselyov. Taken from:
+;; αKanren: A Fresh Name in Nominal Logic Programming
+;; by William E. Byrd and Daniel P. Friedman
+;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
+;; Université Laval Technical Report DIUL-RT-0701
+
+;; Licensing unclear. Probably need to ask Oleg for a disclaimer.
+
+(define-syntax pmatch
+ (syntax-rules (else guard)
+ ((_ (op arg ...) cs ...)
+ (let ((v (op arg ...)))
+ (pmatch v cs ...)))
+ ((_ v) (if #f #f))
+ ((_ v (else e0 e ...)) (begin e0 e ...))
+ ((_ v (pat (guard g ...) e0 e ...) cs ...)
+ (let ((fk (lambda () (pmatch v cs ...))))
+ (ppat v pat
+ (if (and g ...) (begin e0 e ...) (fk))
+ (fk))))
+ ((_ v (pat e0 e ...) cs ...)
+ (let ((fk (lambda () (pmatch v cs ...))))
+ (ppat v pat (begin e0 e ...) (fk))))))
+
+(define-syntax ppat
+ (syntax-rules (_ quote unquote)
+ ((_ v _ kt kf) kt)
+ ((_ v () kt kf) (if (null? v) kt kf))
+ ((_ v (quote lit) kt kf)
+ (if (equal? v (quote lit)) kt kf))
+ ((_ v (unquote var) kt kf) (let ((var v)) kt))
+ ((_ v (x . y) kt kf)
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (ppat vx x (ppat vy y kt kf) kf))
+ kf))
+ ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf))))
--- /dev/null
+;;; Guile VM specific syntaxes and utilities
+
+;; Copyright (C) 2001 Free Software Foundation, Inc
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA
+
+;;; Code:
+
+(define-module (system base syntax)
+ :export (%compute-initargs)
+ :export-syntax (define-type define-record record-case))
+(export-syntax |) ;; emacs doesn't like the |
+
+\f
+;;;
+;;; Keywords by `:KEYWORD
+;;;
+
+(read-set! keywords 'prefix)
+
+\f
+;;;
+;;; Type
+;;;
+
+(define-macro (define-type name sig) sig)
+
+;;;
+;;; Record
+;;;
+
+(define (symbol-trim-both sym pred)
+ (string->symbol (string-trim-both (symbol->string sym) pred)))
+
+(define-macro (define-record def)
+ (let* ((name (car def)) (slots (cdr def))
+ (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+ slots))
+ (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
+ `(begin
+ (define ,name (make-record-type ,(symbol->string name) ',slot-names))
+ (define ,(symbol-append 'make- stem)
+ (let ((slots (list ,@(map (lambda (slot)
+ (if (pair? slot)
+ `(cons ',(car slot) ,(cadr slot))
+ `',slot))
+ slots)))
+ (constructor (record-constructor ,name)))
+ (lambda args
+ (apply constructor (%compute-initargs args slots)))))
+ (define ,(symbol-append stem '?) (record-predicate ,name))
+ ,@(map (lambda (sname)
+ `(define ,(symbol-append stem '- sname)
+ (make-procedure-with-setter
+ (record-accessor ,name ',sname)
+ (record-modifier ,name ',sname))))
+ slot-names))))
+
+(define (%compute-initargs args slots)
+ (define (finish out)
+ (map (lambda (slot)
+ (let ((name (if (pair? slot) (car slot) slot)))
+ (cond ((assq name out) => cdr)
+ ((pair? slot) (cdr slot))
+ (else (error "unbound slot" args slots name)))))
+ slots))
+ (let lp ((in args) (positional slots) (out '()))
+ (cond
+ ((null? in)
+ (finish out))
+ ((keyword? (car in))
+ (let ((sym (keyword->symbol (car in))))
+ (cond
+ ((and (not (memq sym slots))
+ (not (assq sym (filter pair? slots))))
+ (error "unknown slot" sym))
+ ((assq sym out) (error "slot already set" sym out))
+ (else (lp (cddr in) '() (acons sym (cadr in) out))))))
+ ((null? positional)
+ (error "too many initargs" args slots))
+ (else
+ (lp (cdr in) (cdr positional)
+ (acons (car positional) (car in) out))))))
+
+(define-macro (record-case record . clauses)
+ (let ((r (gensym)))
+ (define (process-clause clause)
+ (if (eq? (car clause) 'else)
+ clause
+ (let ((record-type (caar clause))
+ (slots (cdar clause))
+ (body (cdr clause)))
+ `(((record-predicate ,record-type) ,r)
+ (let ,(map (lambda (slot)
+ (if (pair? slot)
+ `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
+ `(,slot ((record-accessor ,record-type ',slot) ,r))))
+ slots)
+ ,@body)))))
+ `(let ((,r ,record))
+ (cond ,@(let ((clauses (map process-clause clauses)))
+ (if (assq 'else clauses)
+ clauses
+ (append clauses `((else (error "unhandled record" ,r))))))))))
+
+
+\f
+;;;
+;;; Variants
+;;;
+
+(define-macro (| . rest)
+ `(begin ,@(map (lambda (def) `(define-record ,def)) rest)))
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+SOURCES = glil.scm ghil.scm inline.scm compile.scm
+modpath = system/il
+include $(top_srcdir)/guilec.mk
--- /dev/null
+;;; GHIL -> GLIL compiler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system il compile)
+ :use-syntax (system base syntax)
+ :use-module (system il glil)
+ :use-module (system il ghil)
+ :use-module (ice-9 common-list)
+ :export (compile))
+
+(define (compile x e . opts)
+ (if (memq :O opts) (set! x (optimize x)))
+ (codegen x))
+
+\f
+;;;
+;;; Stage 2: Optimization
+;;;
+
+(define (optimize x)
+ (record-case x
+ ((<ghil-set> env loc var val)
+ (make-ghil-set env var (optimize val)))
+
+ ((<ghil-if> env loc test then else)
+ (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
+
+ ((<ghil-begin> env loc exps)
+ (make-ghil-begin env loc (map optimize exps)))
+
+ ((<ghil-bind> env loc vars vals body)
+ (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
+
+ ((<ghil-lambda> env loc vars rest meta body)
+ (make-ghil-lambda env loc vars rest meta (optimize body)))
+
+ ((<ghil-inline> env loc instruction args)
+ (make-ghil-inline env loc instruction (map optimize args)))
+
+ ((<ghil-call> env loc proc args)
+ (let ((parent-env env))
+ (record-case proc
+ ;; ((@lambda (VAR...) BODY...) ARG...) =>
+ ;; (@let ((VAR ARG) ...) BODY...)
+ ((<ghil-lambda> env loc vars rest meta body)
+ (cond
+ ((not rest)
+ (for-each (lambda (v)
+ (case (ghil-var-kind v)
+ ((argument) (set! (ghil-var-kind v) 'local)))
+ (set! (ghil-var-env v) parent-env)
+ (ghil-env-add! parent-env v))
+ (ghil-env-variables env)))
+ (else
+ (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
+ (else
+ (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
+
+ (else x)))
+
+\f
+;;;
+;;; Stage 3: Code generation
+;;;
+
+(define *ia-void* (make-glil-void))
+(define *ia-drop* (make-glil-call 'drop 0))
+(define *ia-return* (make-glil-call 'return 0))
+
+(define (make-label) (gensym ":L"))
+
+(define (make-glil-var op env var)
+ (case (ghil-var-kind var)
+ ((argument)
+ (make-glil-argument op (ghil-var-index var)))
+ ((local)
+ (make-glil-local op (ghil-var-index var)))
+ ((external)
+ (do ((depth 0 (1+ depth))
+ (e env (ghil-env-parent e)))
+ ((eq? e (ghil-var-env var))
+ (make-glil-external op depth (ghil-var-index var)))))
+ ((module)
+ (let ((env (ghil-var-env var)))
+ (make-glil-module op (ghil-mod-module (ghil-env-mod env))
+ (ghil-var-name var))))
+ (else (error "Unknown kind of variable:" var))))
+
+(define (codegen ghil)
+ (let ((stack '()))
+ (define (push-code! loc code)
+ (set! stack (cons code stack))
+ (if loc (set! stack (cons (make-glil-source loc) stack))))
+ (define (push-bindings! loc vars)
+ (if (not (null? vars))
+ (push-code!
+ loc
+ (make-glil-bind
+ (map list
+ (map ghil-var-name vars)
+ (map ghil-var-kind vars)
+ (map ghil-var-index vars))))))
+ (define (comp tree tail drop)
+ (define (push-label! label)
+ (push-code! #f (make-glil-label label)))
+ (define (push-branch! loc inst label)
+ (push-code! loc (make-glil-branch inst label)))
+ (define (push-call! loc inst args)
+ (for-each comp-push args)
+ (push-code! loc (make-glil-call inst (length args))))
+ ;; possible tail position
+ (define (comp-tail tree) (comp tree tail drop))
+ ;; push the result
+ (define (comp-push tree) (comp tree #f #f))
+ ;; drop the result
+ (define (comp-drop tree) (comp tree #f #t))
+ ;; drop the result if unnecessary
+ (define (maybe-drop)
+ (if drop (push-code! #f *ia-drop*)))
+ ;; return here if necessary
+ (define (maybe-return)
+ (if tail (push-code! #f *ia-return*)))
+ ;; return this code if necessary
+ (define (return-code! loc code)
+ (if (not drop) (push-code! loc code))
+ (maybe-return))
+ ;; return void if necessary
+ (define (return-void!)
+ (return-code! #f *ia-void*))
+ ;; return object if necessary
+ (define (return-object! loc obj)
+ (return-code! loc (make-glil-const #:obj obj)))
+ ;;
+ ;; dispatch
+ (record-case tree
+ ((<ghil-void>)
+ (return-void!))
+
+ ((<ghil-quote> env loc obj)
+ (return-object! loc obj))
+
+ ((<ghil-quasiquote> env loc exp)
+ (let loop ((x exp))
+ (cond
+ ((list? x)
+ (push-call! #f 'mark '())
+ (for-each loop x)
+ (push-call! #f 'list-mark '()))
+ ((pair? x)
+ (loop (car x))
+ (loop (cdr x))
+ (push-code! #f (make-glil-call 'cons 2)))
+ ((record? x)
+ (record-case x
+ ((<ghil-unquote> env loc exp)
+ (comp-push exp))
+ ((<ghil-unquote-splicing> env loc exp)
+ (comp-push exp)
+ (push-call! #f 'list-break '()))))
+ (else
+ (push-code! #f (make-glil-const #:obj x)))))
+ (maybe-drop)
+ (maybe-return))
+
+ ((<ghil-ref> env loc var)
+ (return-code! loc (make-glil-var 'ref env var)))
+
+ ((<ghil-set> env loc var val)
+ (comp-push val)
+ (push-code! loc (make-glil-var 'set env var))
+ (return-void!))
+
+ ((<ghil-define> env loc var val)
+ (comp-push val)
+ (push-code! loc (make-glil-var 'define env var))
+ (return-void!))
+
+ ((<ghil-if> env loc test then else)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; THEN
+ ;; (br L2)
+ ;; L1: ELSE
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (comp-push test)
+ (push-branch! loc 'br-if-not L1)
+ (comp-tail then)
+ (if (not tail) (push-branch! #f 'br L2))
+ (push-label! L1)
+ (comp-tail else)
+ (if (not tail) (push-label! L2))))
+
+ ((<ghil-and> env loc exps)
+ ;; EXP
+ ;; (br-if-not L1)
+ ;; ...
+ ;; TAIL
+ ;; (br L2)
+ ;; L1: (const #f)
+ ;; L2:
+ (cond ((null? exps) (return-object! loc #t))
+ ((null? (cdr exps)) (comp-tail (car exps)))
+ (else
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (let lp ((exps exps))
+ (cond ((null? (cdr exps))
+ (comp-tail (car exps))
+ (push-branch! #f 'br L2)
+ (push-label! L1)
+ (return-object! #f #f)
+ (push-label! L2)
+ (maybe-return))
+ (else
+ (comp-push (car exps))
+ (push-branch! #f 'br-if-not L1)
+ (lp (cdr exps)))))))))
+
+ ((<ghil-or> env loc exps)
+ ;; EXP
+ ;; (dup)
+ ;; (br-if L1)
+ ;; (drop)
+ ;; ...
+ ;; TAIL
+ ;; L1:
+ (cond ((null? exps) (return-object! loc #f))
+ ((null? (cdr exps)) (comp-tail (car exps)))
+ (else
+ (let ((L1 (make-label)))
+ (let lp ((exps exps))
+ (cond ((null? (cdr exps))
+ (comp-tail (car exps))
+ (push-label! L1)
+ (maybe-return))
+ (else
+ (comp-push (car exps))
+ (push-call! #f 'dup '())
+ (push-branch! #f 'br-if L1)
+ (push-call! #f 'drop '())
+ (lp (cdr exps)))))))))
+
+ ((<ghil-begin> env loc exps)
+ ;; EXPS...
+ ;; TAIL
+ (if (null? exps)
+ (return-void!)
+ (do ((exps exps (cdr exps)))
+ ((null? (cdr exps))
+ (comp-tail (car exps)))
+ (comp-drop (car exps)))))
+
+ ((<ghil-bind> env loc vars vals body)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (for-each comp-push vals)
+ (push-bindings! loc vars)
+ (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
+ (reverse vars))
+ (comp-tail body)
+ (push-code! #f (make-glil-unbind)))
+
+ ((<ghil-lambda> env loc vars rest meta body)
+ (return-code! loc (codegen tree)))
+
+ ((<ghil-inline> env loc inline args)
+ ;; ARGS...
+ ;; (INST NARGS)
+ (push-call! loc inline args)
+ (maybe-drop)
+ (maybe-return))
+
+ ((<ghil-call> env loc proc args)
+ ;; PROC
+ ;; ARGS...
+ ;; ([tail-]call NARGS)
+ (comp-push proc)
+ (push-call! loc (if tail 'tail-call 'call) args)
+ (maybe-drop))))
+ ;;
+ ;; main
+ (record-case ghil
+ ((<ghil-lambda> env loc vars rest meta body)
+ (let* ((evars (ghil-env-variables env))
+ (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
+ (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
+ ;; initialize variable indexes
+ (finalize-index! vars)
+ (finalize-index! locs)
+ (finalize-index! exts)
+ ;; meta bindings
+ (push-bindings! #f vars)
+ ;; export arguments
+ (do ((n 0 (1+ n))
+ (l vars (cdr l)))
+ ((null? l))
+ (let ((v (car l)))
+ (case (ghil-var-kind v)
+ ((external)
+ (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
+ ;; compile body
+ (comp body #t #f)
+ ;; create GLIL
+ (let ((vars (make-glil-vars :nargs (length vars)
+ :nrest (if rest 1 0)
+ :nlocs (length locs)
+ :nexts (length exts))))
+ (make-glil-asm vars meta (reverse! stack))))))))
+
+(define (finalize-index! list)
+ (do ((n 0 (1+ n))
+ (l list (cdr l)))
+ ((null? l))
+ (let ((v (car l))) (set! (ghil-var-index v) n))))
--- /dev/null
+;;; Guile High Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system il ghil)
+ :use-syntax (system base syntax)
+ :use-module (ice-9 regex)
+ :export
+ (<ghil-void> make-ghil-void ghil-void?
+ ghil-void-env ghil-void-loc
+
+ <ghil-quote> make-ghil-quote ghil-quote?
+ ghil-quote-env ghil-quote-loc ghil-quote-obj
+
+ <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
+ ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
+
+ <ghil-unquote> make-ghil-unquote ghil-unquote?
+ ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
+
+ <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
+ ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
+
+ <ghil-ref> make-ghil-ref ghil-ref?
+ ghil-ref-env ghil-ref-loc ghil-ref-var
+
+ <ghil-set> make-ghil-set ghil-set?
+ ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
+
+ <ghil-define> make-ghil-define ghil-define?
+ ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
+
+ <ghil-if> make-ghil-if ghil-if?
+ ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
+
+ <ghil-and> make-ghil-and ghil-and?
+ ghil-and-env ghil-and-loc ghil-and-exps
+
+ <ghil-or> make-ghil-or ghil-or?
+ ghil-or-env ghil-or-loc ghil-or-exps
+
+ <ghil-begin> make-ghil-begin ghil-begin?
+ ghil-begin-env ghil-begin-loc ghil-begin-exps
+
+ <ghil-bind> make-ghil-bind ghil-bind?
+ ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
+
+ <ghil-lambda> make-ghil-lambda ghil-lambda?
+ ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
+ ghil-lambda-meta ghil-lambda-body
+
+ <ghil-inline> make-ghil-inline ghil-inline?
+ ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
+
+ <ghil-call> make-ghil-call ghil-call?
+ ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
+
+ <ghil-var> make-ghil-var ghil-var?
+ ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value
+ ghil-var-index
+
+ <ghil-mod> make-ghil-mod ghil-mod?
+ ghil-mod-module ghil-mod-table ghil-mod-imports
+
+ <ghil-env> make-ghil-env ghil-env?
+ ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables
+
+ ghil-env-add! ghil-lookup ghil-define
+ ghil-env-toplevel?
+ call-with-ghil-environment call-with-ghil-bindings))
+
+\f
+;;;
+;;; Parse tree
+;;;
+
+(define-type <ghil>
+ (|
+ ;; Objects
+ (<ghil-void> env loc)
+ (<ghil-quote> env loc obj)
+ (<ghil-quasiquote> env loc exp)
+ (<ghil-unquote> env loc exp)
+ (<ghil-unquote-splicing> env loc exp)
+ ;; Variables
+ (<ghil-ref> env loc var)
+ (<ghil-set> env loc var val)
+ (<ghil-define> env loc var val)
+ ;; Controls
+ (<ghil-if> env loc test then else)
+ (<ghil-and> env loc exps)
+ (<ghil-or> env loc exps)
+ (<ghil-begin> env loc exps)
+ (<ghil-bind> env loc vars vals body)
+ (<ghil-lambda> env loc vars rest meta body)
+ (<ghil-call> env loc proc args)
+ (<ghil-inline> env loc inline args)))
+
+\f
+;;;
+;;; Variables
+;;;
+
+(define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
+
+\f
+;;;
+;;; Modules
+;;;
+
+(define-record (<ghil-mod> module (table '()) (imports '())))
+
+\f
+;;;
+;;; Environments
+;;;
+
+(define-record (<ghil-env> mod parent (table '()) (variables '())))
+
+(define %make-ghil-env make-ghil-env)
+(define (make-ghil-env e)
+ (record-case e
+ ((<ghil-mod>) (%make-ghil-env :mod e :parent e))
+ ((<ghil-env> mod) (%make-ghil-env :mod mod :parent e))))
+
+(define (ghil-env-toplevel? e)
+ (eq? (ghil-env-mod e) (ghil-env-parent e)))
+
+(define (ghil-env-ref env sym)
+ (assq-ref (ghil-env-table env) sym))
+
+(define-macro (push! item loc)
+ `(set! ,loc (cons ,item ,loc)))
+(define-macro (apush! k v loc)
+ `(set! ,loc (acons ,k ,v ,loc)))
+(define-macro (apopq! k loc)
+ `(set! ,loc (assq-remove! ,loc ,k)))
+
+(define (ghil-env-add! env var)
+ (apush! (ghil-var-name var) var (ghil-env-table env))
+ (push! var (ghil-env-variables env)))
+
+(define (ghil-env-remove! env var)
+ (apopq! (ghil-var-name var) (ghil-env-table env)))
+
+\f
+;;;
+;;; Public interface
+;;;
+
+(define (fix-ghil-mod! mod for-sym)
+ ;;; So, these warnings happen for all instances of define-module.
+ ;;; Rather than fixing the problem, I'm going to suppress the common
+ ;;; warnings.
+ (if (not (eq? for-sym 'process-define-module))
+ (warn "during lookup of" for-sym ":"
+ (ghil-mod-module mod) "!= current" (current-module)))
+ (if (not (null? (ghil-mod-table mod)))
+ (warn "throwing away old variable table"
+ (ghil-mod-module) (ghil-mod-table mod)))
+ (set! (ghil-mod-module mod) (current-module))
+ (set! (ghil-mod-table mod) '())
+ (set! (ghil-mod-imports mod) '()))
+
+;; looking up a var has side effects?
+(define (ghil-lookup env sym)
+ (or (ghil-env-ref env sym)
+ (let loop ((e (ghil-env-parent env)))
+ (record-case e
+ ((<ghil-mod> module table imports)
+ (cond ((not (eq? module (current-module)))
+ ;; FIXME: the primitive-eval in eval-case and/or macro
+ ;; expansion can have side effects on the compilation
+ ;; environment, for example changing the current
+ ;; module. We probably need to add a special case in
+ ;; compilation to handle define-module.
+ (fix-ghil-mod! e sym)
+ (loop e))
+ ((assq-ref table sym)) ;; when does this hit?
+ (else
+ ;; although we could bind the variable here, in
+ ;; practice further toplevel definitions in this
+ ;; compilation unit could change how we would resolve
+ ;; this binding, so punt and memoize the lookup at
+ ;; runtime always.
+ (let ((var (make-ghil-var (make-ghil-env e) sym 'module)))
+ (apush! sym var table)
+ var))))
+ ((<ghil-env> mod parent table variables)
+ (let ((found (assq-ref table sym)))
+ (if found
+ (begin (set! (ghil-var-kind found) 'external) found)
+ (loop parent))))))))
+
+(define (ghil-define mod sym)
+ (if (not (eq? (ghil-mod-module mod) (current-module)))
+ (fix-ghil-mod! mod sym))
+ (or (assq-ref (ghil-mod-table mod) sym)
+ (let ((var (make-ghil-var (make-ghil-env mod) sym 'module)))
+ (apush! sym var (ghil-mod-table mod))
+ var)))
+
+(define (call-with-ghil-environment e syms func)
+ (let* ((e (make-ghil-env e))
+ (vars (map (lambda (s)
+ (let ((v (make-ghil-var e s 'argument)))
+ (ghil-env-add! e v) v))
+ syms)))
+ (func e vars)))
+
+(define (call-with-ghil-bindings e syms func)
+ (let* ((vars (map (lambda (s)
+ (let ((v (make-ghil-var e s 'local)))
+ (ghil-env-add! e v) v))
+ syms))
+ (ret (func vars)))
+ (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+ ret))
+
+\f
+;;;
+;;; Parser
+;;;
+
+;;; (define-public (parse-ghil x e)
+;;; (parse `(@lambda () ,x) (make-ghil-mod e)))
+;;;
+;;; (define (parse x e)
+;;; (cond ((pair? x) (parse-pair x e))
+;;; ((symbol? x)
+;;; (let ((str (symbol->string x)))
+;;; (case (string-ref str 0)
+;;; ((#\@) (error "Invalid use of IL primitive" x))
+;;; ((#\:) (let ((sym (string->symbol (substring str 1))))
+;;; (<ghil-quote> (symbol->keyword sym))))
+;;; (else (<ghil-ref> e (ghil-lookup e x))))))
+;;; (else (<ghil-quote> x))))
+;;;
+;;; (define (map-parse x e)
+;;; (map (lambda (x) (parse x e)) x))
+;;;
+;;; (define (parse-pair x e)
+;;; (let ((head (car x)) (tail (cdr x)))
+;;; (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
+;;; (if (ghil-primitive-macro? head)
+;;; (parse (apply (ghil-macro-expander head) tail) e)
+;;; (parse-primitive head tail e))
+;;; (<ghil-call> e (parse head e) (map-parse tail e)))))
+;;;
+;;; (define (parse-primitive prim args e)
+;;; (case prim
+;;; ;; (@ IDENTIFIER)
+;;; ((@)
+;;; (match args
+;;; (()
+;;; (<ghil-ref> e (make-ghil-var '@ '@ 'module)))
+;;; ((identifier)
+;;; (receive (module name) (identifier-split identifier)
+;;; (<ghil-ref> e (make-ghil-var module name 'module))))))
+;;;
+;;; ;; (@@ OP ARGS...)
+;;; ((@@)
+;;; (match args
+;;; ((op . args)
+;;; (<ghil-inline> op (map-parse args e)))))
+;;;
+;;; ;; (@void)
+;;; ((@void)
+;;; (match args
+;;; (() (<ghil-void>))))
+;;;
+;;; ;; (@quote OBJ)
+;;; ((@quote)
+;;; (match args
+;;; ((obj)
+;;; (<ghil-quote> obj))))
+;;;
+;;; ;; (@define NAME VAL)
+;;; ((@define)
+;;; (match args
+;;; ((name val)
+;;; (let ((v (ghil-lookup e name)))
+;;; (<ghil-set> e v (parse val e))))))
+;;;
+;;; ;; (@set! NAME VAL)
+;;; ((@set!)
+;;; (match args
+;;; ((name val)
+;;; (let ((v (ghil-lookup e name)))
+;;; (<ghil-set> e v (parse val e))))))
+;;;
+;;; ;; (@if TEST THEN [ELSE])
+;;; ((@if)
+;;; (match args
+;;; ((test then)
+;;; (<ghil-if> (parse test e) (parse then e) (<ghil-void>)))
+;;; ((test then else)
+;;; (<ghil-if> (parse test e) (parse then e) (parse else e)))))
+;;;
+;;; ;; (@begin BODY...)
+;;; ((@begin)
+;;; (parse-body args e))
+;;;
+;;; ;; (@let ((SYM INIT)...) BODY...)
+;;; ((@let)
+;;; (match args
+;;; ((((sym init) ...) body ...)
+;;; (let* ((vals (map-parse init e))
+;;; (vars (map (lambda (s)
+;;; (let ((v (make-ghil-var e s 'local)))
+;;; (ghil-env-add! e v) v))
+;;; sym))
+;;; (body (parse-body body e)))
+;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+;;; (<ghil-bind> e vars vals body)))))
+;;;
+;;; ;; (@letrec ((SYM INIT)...) BODY...)
+;;; ((@letrec)
+;;; (match args
+;;; ((((sym init) ...) body ...)
+;;; (let* ((vars (map (lambda (s)
+;;; (let ((v (make-ghil-var e s 'local)))
+;;; (ghil-env-add! e v) v))
+;;; sym))
+;;; (vals (map-parse init e))
+;;; (body (parse-body body e)))
+;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+;;; (<ghil-bind> e vars vals body)))))
+;;;
+;;; ;; (@lambda FORMALS BODY...)
+;;; ((@lambda)
+;;; (match args
+;;; ((formals . body)
+;;; (receive (syms rest) (parse-formals formals)
+;;; (let* ((e (make-ghil-env e))
+;;; (vars (map (lambda (s)
+;;; (let ((v (make-ghil-var e s 'argument)))
+;;; (ghil-env-add! e v) v))
+;;; syms)))
+;;; (<ghil-lambda> e vars rest (parse-body body e)))))))
+;;;
+;;; ;; (@eval-case CLAUSE...)
+;;; ((@eval-case)
+;;; (let loop ((clauses args))
+;;; (cond ((null? clauses) (<ghil-void>))
+;;; ((or (eq? (caar clauses) '@else)
+;;; (and (memq 'load-toplevel (caar clauses))
+;;; (ghil-env-toplevel? e)))
+;;; (parse-body (cdar clauses) e))
+;;; (else
+;;; (loop (cdr clauses))))))
+;;;
+;;; (else (error "Unknown primitive:" prim))))
+;;;
+;;; (define (parse-body x e)
+;;; (<ghil-begin> (map-parse x e)))
+;;;
+;;; (define (parse-formals formals)
+;;; (cond
+;;; ;; (@lambda x ...)
+;;; ((symbol? formals) (values (list formals) #t))
+;;; ;; (@lambda (x y z) ...)
+;;; ((list? formals) (values formals #f))
+;;; ;; (@lambda (x y . z) ...)
+;;; ((pair? formals)
+;;; (let loop ((l formals) (v '()))
+;;; (if (pair? l)
+;;; (loop (cdr l) (cons (car l) v))
+;;; (values (reverse! (cons l v)) #t))))
+;;; (else (error "Invalid formals:" formals))))
+;;;
+;;; (define (identifier-split identifier)
+;;; (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
+;;; (if m
+;;; (values (string->symbol (match:prefix m))
+;;; (string->symbol (match:substring m 1)))
+;;; (values #f identifier))))
--- /dev/null
+;;; Guile Low Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system il glil)
+ :use-syntax (system base syntax)
+ :export
+ (pprint-glil
+ <glil-vars> make-glil-vars
+ glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
+
+ <glil-asm> make-glil-asm glil-asm?
+ glil-asm-vars glil-asm-meta glil-asm-body
+
+ <glil-bind> make-glil-bind glil-bind?
+ glil-bind-vars
+
+ <glil-unbind> make-glil-unbind glil-unbind?
+
+ <glil-source> make-glil-source glil-source?
+ glil-source-loc
+
+ <glil-void> make-glil-void glil-void?
+
+ <glil-const> make-glil-const glil-const?
+ glil-const-obj
+
+ <glil-argument> make-glil-argument glil-argument?
+ glil-argument-op glil-argument-index
+
+ <glil-local> make-glil-local glil-local?
+ glil-local-op glil-local-index
+
+ <glil-external> make-glil-external glil-external?
+ glil-external-op glil-external-depth glil-external-index
+
+ <glil-module> make-glil-module glil-module?
+ glil-module-op glil-module-module glil-module-index
+
+ <glil-late-bound> make-glil-late-bound glil-late-bound?
+ glil-late-bound-op glil-late-bound-name
+
+ <glil-label> make-glil-label glil-label?
+ glil-label-label
+
+ <glil-branch> make-glil-branch glil-branch?
+ glil-branch-int glil-branch-label
+
+ <glil-call> make-glil-call glil-call?
+ glil-call-int glil-call-nargs))
+
+(define-record (<glil-vars> nargs nrest nlocs nexts))
+
+(define-type <glil>
+ (|
+ ;; Meta operations
+ (<glil-asm> vars meta body)
+ (<glil-bind> vars)
+ (<glil-unbind>)
+ (<glil-source> loc)
+ ;; Objects
+ (<glil-void>)
+ (<glil-const> obj)
+ ;; Variables
+ (<glil-argument> op index)
+ (<glil-local> op index)
+ (<glil-external> op depth index)
+ (<glil-module> op module name)
+ (<glil-late-bound> op name)
+ ;; Controls
+ (<glil-label> label)
+ (<glil-branch> inst label)
+ (<glil-call> inst nargs)))
+
+\f
+;;;
+;;; Parser
+;;;
+
+;;; (define (parse-glil x)
+;;; (match x
+;;; (('@asm args . body)
+;;; (let* ((env (make-new-env e))
+;;; (args (parse-args args env)))
+;;; (make-asm env args (map-parse body env))))
+;;; (else
+;;; (error "Invalid assembly code:" x))))
+;;;
+;;; (define (parse-args x e)
+;;; (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t))
+;;; ((list? x) (make-args (map make-local-var x) #f))
+;;; (else (let loop ((l x) (v '()))
+;;; (if (pair? l)
+;;; (loop (cdr l) (cons (car l) v))
+;;; (make-args (map make-local-var
+;;; (reverse! (cons l v)))
+;;; #t)))))))
+;;; (for-each (lambda (v) (env-add! e v)) (args-vars args))
+;;; args))
+;;;
+;;; (define (map-parse x e)
+;;; (map (lambda (x) (parse x e)) x))
+;;;
+;;; (define (parse x e)
+;;; (match x
+;;; ;; (@asm ARGS BODY...)
+;;; (('@asm args . body)
+;;; (parse-asm x e))
+;;; ;; (@bind VARS BODY...)
+;;; ;; (@block VARS BODY...)
+;;; (((or '@bind '@block) vars . body)
+;;; (let* ((offset (env-nvars e))
+;;; (vars (args-vars (parse-args vars e)))
+;;; (block (make-block (car x) offset vars (map-parse body e))))
+;;; (for-each (lambda (v) (env-remove! e)) vars)
+;;; block))
+;;; ;; (void)
+;;; (('void)
+;;; (make-void))
+;;; ;; (const OBJ)
+;;; (('const obj)
+;;; (make-const obj))
+;;; ;; (ref NAME)
+;;; ;; (set NAME)
+;;; (((or 'ref 'set) name)
+;;; (make-access (car x) (env-ref e name)))
+;;; ;; (label LABEL)
+;;; (('label label)
+;;; (make-label label))
+;;; ;; (br-if LABEL)
+;;; ;; (jump LABEL)
+;;; (((or 'br-if 'jump) label)
+;;; (make-instl (car x) label))
+;;; ;; (call NARGS)
+;;; ;; (tail-call NARGS)
+;;; (((or 'call 'tail-call) n)
+;;; (make-instn (car x) n))
+;;; ;; (INST)
+;;; ((inst)
+;;; (if (instruction? inst)
+;;; (make-inst inst)
+;;; (error "Unknown instruction:" inst)))))
+
+\f
+;;;
+;;; Unparser
+;;;
+
+(define (unparse glil)
+ (record-case glil
+ ;; meta
+ ((<glil-asm> vars meta body)
+ `(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
+ ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
+ ,meta
+ ,@(map unparse body)))
+ ((<glil-bind> vars) `(@bind ,@vars))
+ ((<glil-unbind>) `(@unbind))
+ ((<glil-source> loc) `(@source ,loc))
+ ;; constants
+ ((<glil-void>) `(void))
+ ((<glil-const> obj) `(const ,obj))
+ ;; variables
+ ((<glil-argument> op index)
+ `(,(symbol-append 'argument- op) ,index))
+ ((<glil-local> op index)
+ `(,(symbol-append 'local- op) ,index))
+ ((<glil-external> op depth index)
+ `(,(symbol-append 'external- op) ,depth ,index))
+ ((<glil-module> op module name)
+ `(,(symbol-append 'module- op) ,module ,name))
+ ;; controls
+ ((<glil-label> label) label)
+ ((<glil-branch> inst label) `(,inst ,label))
+ ((<glil-call> inst nargs) `(,inst ,nargs))))
+
+\f
+;;;
+;;; Printer
+;;;
+
+(define (pprint-glil glil . port)
+ (let ((port (if (pair? port) (car port) (current-output-port))))
+ (let print ((code (unparse glil)) (column 0))
+ (display (make-string column #\space) port)
+ (cond ((and (pair? code) (eq? (car code) '@asm))
+ (format port "(@asm ~A\n" (cadr code))
+ (let ((col (+ column 2)))
+ (let loop ((l (cddr code)))
+ (print (car l) col)
+ (if (null? (cdr l))
+ (display ")" port)
+ (begin (newline port) (loop (cdr l)))))))
+ (else (write code port))))
+ (newline port)))
--- /dev/null
+;;; GHIL macros
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system il inline)
+ :use-module (system base syntax)
+ :use-module (system il ghil)
+ :use-module (srfi srfi-16)
+ :export (*inline-table* define-inline try-inline try-inline-with-env))
+
+(define *inline-table* '())
+
+(define-macro (define-inline sym . clauses)
+ (define (inline-args args)
+ (let lp ((in args) (out '()))
+ (cond ((null? in) `(list ,@(reverse out)))
+ ((symbol? in) `(cons* ,@(reverse out) ,in))
+ ((pair? (car in))
+ (lp (cdr in)
+ (cons `(or (try-inline ,(caar in) ,(inline-args (cdar in)))
+ (error "what" ',(car in)))
+ out)))
+ ((symbol? (car in))
+ ;; assume it's locally bound
+ (lp (cdr in) (cons (car in) out)))
+ ((number? (car in))
+ (lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out)))
+ (else
+ (error "what what" (car in))))))
+ (define (consequent exp)
+ (cond
+ ((pair? exp)
+ `(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp))))
+ ((symbol? exp)
+ ;; assume locally bound
+ exp)
+ ((number? exp)
+ `(make-ghil-quote #f #f ,exp))
+ (else (error "bad consequent yall" exp))))
+ `(set! *inline-table*
+ (assq-set! *inline-table*
+ ,sym
+ (case-lambda
+ ,@(let lp ((in clauses) (out '()))
+ (if (null? in)
+ (reverse (cons '(else #f) out))
+ (lp (cddr in)
+ (cons `(,(car in)
+ ,(consequent (cadr in))) out))))))))
+
+(define (try-inline head-value args)
+ (and=> (assq-ref *inline-table* head-value)
+ (lambda (proc) (apply proc args))))
+
+(define (ghil-env-ref env sym)
+ (assq-ref (ghil-env-table env) sym))
+
+
+(define (try-inline-with-env env loc exp)
+ (let ((sym (car exp)))
+ (and (not (ghil-env-ref env sym))
+ (let loop ((e (ghil-env-parent env)))
+ (record-case e
+ ((<ghil-mod> module table imports)
+ (and (not (assq-ref table sym))
+ (module-bound? module sym)
+ (try-inline (module-ref module sym) (cdr exp))))
+ ((<ghil-env> mod parent table variables)
+ (and (not (assq-ref table sym))
+ (loop parent))))))))
+
+(define-inline eq? (x y)
+ (eq? x y))
+
+(define-inline eqv? (x y)
+ (eqv? x y))
+
+(define-inline equal? (x y)
+ (equal? x y))
+
+(define-inline = (x y)
+ (ee? x y))
+
+(define-inline < (x y)
+ (lt? x y))
+
+(define-inline > (x y)
+ (gt? x y))
+
+(define-inline <= (x y)
+ (le? x y))
+
+(define-inline >= (x y)
+ (ge? x y))
+
+(define-inline zero? (x)
+ (ee? x 0))
+
+(define-inline +
+ () 0
+ (x) x
+ (x y) (add x y)
+ (x y . rest) (add x (+ y . rest)))
+
+(define-inline *
+ () 1
+ (x) x
+ (x y) (mul x y)
+ (x y . rest) (mul x (* y . rest)))
+
+(define-inline -
+ (x) (sub 0 x)
+ (x y) (sub x y)
+ (x y . rest) (sub x (+ y . rest)))
+
+(define-inline 1-
+ (x) (sub x 1))
+
+(define-inline /
+ (x) (div 1 x)
+ (x y) (div x y)
+ (x y . rest) (div x (* y . rest)))
+
+(define-inline quotient (x y)
+ (quo x y))
+
+(define-inline remainder (x y)
+ (rem x y))
+
+(define-inline modulo (x y)
+ (mod x y))
+
+(define-inline not (x)
+ (not x))
+
+(define-inline pair? (x)
+ (pair? x))
+
+(define-inline cons (x y)
+ (cons x y))
+
+(define-inline car (x) (car x))
+(define-inline cdr (x) (cdr x))
+
+(define-inline set-car! (x y) (set-car! x y))
+(define-inline set-cdr! (x y) (set-cdr! x y))
+
+(define-inline caar (x) (car (car x)))
+(define-inline cadr (x) (car (cdr x)))
+(define-inline cdar (x) (cdr (car x)))
+(define-inline cddr (x) (cdr (cdr x)))
+(define-inline caaar (x) (car (car (car x))))
+(define-inline caadr (x) (car (car (cdr x))))
+(define-inline cadar (x) (car (cdr (car x))))
+(define-inline caddr (x) (car (cdr (cdr x))))
+(define-inline cdaar (x) (cdr (car (car x))))
+(define-inline cdadr (x) (cdr (car (cdr x))))
+(define-inline cddar (x) (cdr (cdr (car x))))
+(define-inline cdddr (x) (cdr (cdr (cdr x))))
+(define-inline caaaar (x) (car (car (car (car x)))))
+(define-inline caaadr (x) (car (car (car (cdr x)))))
+(define-inline caadar (x) (car (car (cdr (car x)))))
+(define-inline caaddr (x) (car (car (cdr (cdr x)))))
+(define-inline cadaar (x) (car (cdr (car (car x)))))
+(define-inline cadadr (x) (car (cdr (car (cdr x)))))
+(define-inline caddar (x) (car (cdr (cdr (car x)))))
+(define-inline cadddr (x) (car (cdr (cdr (cdr x)))))
+(define-inline cdaaar (x) (cdr (car (car (car x)))))
+(define-inline cdaadr (x) (cdr (car (car (cdr x)))))
+(define-inline cdadar (x) (cdr (car (cdr (car x)))))
+(define-inline cdaddr (x) (cdr (car (cdr (cdr x)))))
+(define-inline cddaar (x) (cdr (cdr (car (car x)))))
+(define-inline cddadr (x) (cdr (cdr (car (cdr x)))))
+(define-inline cdddar (x) (cdr (cdr (cdr (car x)))))
+(define-inline cddddr (x) (cdr (cdr (cdr (cdr x)))))
+
+(define-inline null? (x)
+ (null? x))
+
+(define-inline list? (x)
+ (list? x))
+
+(define-inline apply (proc . args)
+ (apply proc . args))
+
+(define-inline cons*
+ (x) x
+ (x y) (cons x y)
+ (x y . rest) (cons x (cons* y . rest)))
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+NOCOMP_SOURCES = describe.scm
+SOURCES = repl.scm common.scm command.scm
+modpath = system/repl
+include $(top_srcdir)/guilec.mk
--- /dev/null
+;;; Repl commands
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl command)
+ :use-syntax (system base syntax)
+ :use-module (system base pmatch)
+ :use-module (system base compile)
+ :use-module (system repl common)
+ :use-module (system vm objcode)
+ :use-module (system vm program)
+ :use-module (system vm vm)
+ :autoload (system base language) (lookup-language)
+ :autoload (system il glil) (pprint-glil)
+ :autoload (system vm disasm) (disassemble-program disassemble-objcode)
+ :autoload (system vm debug) (vm-debugger vm-backtrace)
+ :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
+ :autoload (system vm profile) (vm-profile)
+ :use-module (ice-9 format)
+ :use-module (ice-9 session)
+ :use-module (ice-9 documentation)
+ :use-module (ice-9 and-let-star)
+ :export (meta-command))
+
+\f
+;;;
+;;; Meta command interface
+;;;
+
+(define *command-table*
+ '((help (help h) (apropos a) (describe d) (option o) (quit q))
+ (module (module m) (import i) (load l) (binding b))
+ (language (language L))
+ (compile (compile c) (compile-file cc)
+ (disassemble x) (disassemble-file xx))
+ (profile (time t) (profile pr))
+ (debug (backtrace bt) (debugger db) (trace tr) (step st))
+ (system (gc) (statistics stat))))
+
+(define (group-name g) (car g))
+(define (group-commands g) (cdr g))
+
+;; Hack, until core can be extended.
+(define procedure-documentation
+ (let ((old-definition procedure-documentation))
+ (lambda (p)
+ (if (program? p)
+ (program-documentation p)
+ (old-definition p)))))
+
+(define *command-module* (current-module))
+(define (command-name c) (car c))
+(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
+(define (command-procedure c) (module-ref *command-module* (command-name c)))
+(define (command-doc c) (procedure-documentation (command-procedure c)))
+
+(define (command-usage c)
+ (let ((doc (command-doc c)))
+ (substring doc 0 (string-index doc #\newline))))
+
+(define (command-summary c)
+ (let* ((doc (command-doc c))
+ (start (1+ (string-index doc #\newline))))
+ (cond ((string-index doc #\newline start)
+ => (lambda (end) (substring doc start end)))
+ (else (substring doc start)))))
+
+(define (lookup-group name)
+ (assq name *command-table*))
+
+(define (lookup-command key)
+ (let loop ((groups *command-table*) (commands '()))
+ (cond ((and (null? groups) (null? commands)) #f)
+ ((null? commands)
+ (loop (cdr groups) (cdar groups)))
+ ((memq key (car commands)) (car commands))
+ (else (loop groups (cdr commands))))))
+
+(define (display-group group . opts)
+ (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
+ (for-each (lambda (c)
+ (display-summary (command-usage c)
+ (command-abbrev c)
+ (command-summary c)))
+ (group-commands group))
+ (newline))
+
+(define (display-command command)
+ (display "Usage: ")
+ (display (command-doc command))
+ (newline))
+
+(define (display-summary usage abbrev summary)
+ (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
+ (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
+
+(define (meta-command repl line)
+ (let ((input (call-with-input-string (string-append "(" line ")") read)))
+ (if (not (null? input))
+ (do ((key (car input))
+ (args (cdr input) (cdr args))
+ (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
+ ((or (null? args)
+ (not (symbol? (car args)))
+ (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
+ (let ((c (lookup-command key)))
+ (if c
+ (cond ((memq :h opts) (display-command c))
+ (else (apply (command-procedure c)
+ repl (append! args (reverse! opts)))))
+ (user-error "Unknown meta command: ~A" key))))))))
+
+\f
+;;;
+;;; Help commands
+;;;
+
+(define (help repl . args)
+ "help [GROUP]
+List available meta commands.
+A command group name can be given as an optional argument.
+Without any argument, a list of help commands and command groups
+are displayed, as you have already seen ;)"
+ (pmatch args
+ (()
+ (display-group (lookup-group 'help))
+ (display "Command Groups:\n\n")
+ (display-summary "help all" #f "List all commands")
+ (for-each (lambda (g)
+ (let* ((name (symbol->string (group-name g)))
+ (usage (string-append "help " name))
+ (header (string-append "List " name " commands")))
+ (display-summary usage #f header)))
+ (cdr *command-table*))
+ (newline)
+ (display "Type `,COMMAND -h' to show documentation of each command.")
+ (newline))
+ ((all)
+ (for-each display-group *command-table*))
+ ((,group) (guard (lookup-group group))
+ (display-group (lookup-group group)))
+ (else
+ (user-error "Unknown command group: ~A" (car args)))))
+
+(define guile:apropos apropos)
+(define (apropos repl regexp)
+ "apropos REGEXP
+Find bindings/modules/packages."
+ (guile:apropos (->string regexp)))
+
+(define (describe repl obj)
+ "describe OBJ
+Show description/documentation."
+ (display (object-documentation (repl-eval repl obj)))
+ (newline))
+
+(define (option repl . args)
+ "option [KEY VALUE]
+List/show/set options."
+ (pmatch args
+ (()
+ (for-each (lambda (key+val)
+ (format #t "~A\t~A\n" (car key+val) (cdr key+val)))
+ (repl-options repl)))
+ ((,key)
+ (display (repl-option-ref repl key))
+ (newline))
+ ((,key ,val)
+ (repl-option-set! repl key val)
+ (case key
+ ((trace)
+ (let ((vm (repl-vm repl)))
+ (if val
+ (apply vm-trace-on vm val)
+ (vm-trace-off vm))))))))
+
+(define (quit repl)
+ "quit
+Quit this session."
+ (throw 'quit))
+
+\f
+;;;
+;;; Module commands
+;;;
+
+(define (module repl . args)
+ "module [MODULE]
+Change modules / Show current module."
+ (pmatch args
+ (() (puts (module-name (current-module))))
+ ((,mod-name) (guard (list? mod-name))
+ (set-current-module (resolve-module mod-name)))
+ (,mod-name (set-current-module (resolve-module mod-name)))))
+
+(define (import repl . args)
+ "import [MODULE ...]
+Import modules / List those imported."
+ (let ()
+ (define (use name)
+ (let ((mod (resolve-interface name)))
+ (if mod
+ (module-use! (current-module) mod)
+ (user-error "No such module: ~A" name))))
+ (if (null? args)
+ (for-each puts (map module-name (module-uses (current-module))))
+ (for-each use args))))
+
+(define (load repl file . opts)
+ "load FILE
+Load a file in the current module.
+
+ -f Load source file (see `compile')"
+ (let* ((file (->string file))
+ (objcode (if (memq :f opts)
+ (apply load-source-file file opts)
+ (apply load-file file opts))))
+ (vm-load (repl-vm repl) objcode)))
+
+(define (binding repl . opts)
+ "binding
+List current bindings."
+ (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
+ (current-module)))
+
+\f
+;;;
+;;; Language commands
+;;;
+
+(define (language repl name)
+ "language LANGUAGE
+Change languages."
+ (set! (repl-language repl) (lookup-language name))
+ (repl-welcome repl))
+
+\f
+;;;
+;;; Compile commands
+;;;
+
+(define (compile repl form . opts)
+ "compile FORM
+Generate compiled code.
+
+ -e Stop after expanding syntax/macro
+ -t Stop after translating into GHIL
+ -c Stop after generating GLIL
+
+ -O Enable optimization
+ -D Add debug information"
+ (let ((x (apply repl-compile repl form opts)))
+ (cond ((or (memq :e opts) (memq :t opts)) (puts x))
+ ((memq :c opts) (pprint-glil x))
+ (else (disassemble-objcode x)))))
+
+(define guile:compile-file compile-file)
+(define (compile-file repl file . opts)
+ "compile-file FILE
+Compile a file."
+ (apply guile:compile-file (->string file) opts))
+
+(define (disassemble repl prog)
+ "disassemble PROGRAM
+Disassemble a program."
+ (disassemble-program (repl-eval repl prog)))
+
+(define (disassemble-file repl file)
+ "disassemble-file FILE
+Disassemble a file."
+ (disassemble-objcode (load-objcode (->string file))))
+
+\f
+;;;
+;;; Profile commands
+;;;
+
+(define (time repl form)
+ "time FORM
+Time execution."
+ (let* ((vms-start (vm-stats (repl-vm repl)))
+ (gc-start (gc-run-time))
+ (tms-start (times))
+ (result (repl-eval repl form))
+ (tms-end (times))
+ (gc-end (gc-run-time))
+ (vms-end (vm-stats (repl-vm repl))))
+ (define (get proc start end)
+ (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
+ (repl-print repl result)
+ (display "clock utime stime cutime cstime gctime\n")
+ (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
+ (get tms:clock tms-start tms-end)
+ (get tms:utime tms-start tms-end)
+ (get tms:stime tms-start tms-end)
+ (get tms:cutime tms-start tms-end)
+ (get tms:cstime tms-start tms-end)
+ (get identity gc-start gc-end))
+ result))
+
+(define (profile repl form . opts)
+ "profile FORM
+Profile execution."
+ (apply vm-profile
+ (repl-vm repl)
+ (repl-compile repl form)
+ opts))
+
+\f
+;;;
+;;; Debug commands
+;;;
+
+(define (backtrace repl)
+ "backtrace
+Display backtrace."
+ (vm-backtrace (repl-vm repl)))
+
+(define (debugger repl)
+ "debugger
+Start debugger."
+ (vm-debugger (repl-vm repl)))
+
+(define (trace repl form . opts)
+ "trace FORM
+Trace execution.
+
+ -s Display stack
+ -l Display local variables
+ -e Display external variables
+ -b Bytecode level trace"
+ (apply vm-trace (repl-vm repl) (repl-compile repl form) opts))
+
+(define (step repl)
+ "step FORM
+Step execution."
+ (display "Not implemented yet\n"))
+
+\f
+;;;
+;;; System commands
+;;;
+
+(define guile:gc gc)
+(define (gc repl)
+ "gc
+Garbage collection."
+ (guile:gc))
+
+(define (statistics repl)
+ "statistics
+Display statistics."
+ (let ((this-tms (times))
+ (this-vms (vm-stats (repl-vm repl)))
+ (this-gcs (gc-stats))
+ (last-tms (repl-tm-stats repl))
+ (last-vms (repl-vm-stats repl))
+ (last-gcs (repl-gc-stats repl)))
+ ;; GC times
+ (let ((this-times (assq-ref this-gcs 'gc-times))
+ (last-times (assq-ref last-gcs 'gc-times)))
+ (display-diff-stat "GC times:" #t this-times last-times "times")
+ (newline))
+ ;; Memory size
+ (let ((this-cells (assq-ref this-gcs 'cells-allocated))
+ (this-heap (assq-ref this-gcs 'cell-heap-size))
+ (this-bytes (assq-ref this-gcs 'bytes-malloced))
+ (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
+ (display-stat-title "Memory size:" "current" "limit")
+ (display-stat "heap" #f this-cells this-heap "cells")
+ (display-stat "malloc" #f this-bytes this-malloc "bytes")
+ (newline))
+ ;; Cells collected
+ (let ((this-marked (assq-ref this-gcs 'cells-marked))
+ (last-marked (assq-ref last-gcs 'cells-marked))
+ (this-swept (assq-ref this-gcs 'cells-swept))
+ (last-swept (assq-ref last-gcs 'cells-swept)))
+ (display-stat-title "Cells collected:" "diff" "total")
+ (display-diff-stat "marked" #f this-marked last-marked "cells")
+ (display-diff-stat "swept" #f this-swept last-swept "cells")
+ (newline))
+ ;; GC time taken
+ (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken))
+ (last-mark (assq-ref last-gcs 'gc-mark-time-taken))
+ (this-total (assq-ref this-gcs 'gc-time-taken))
+ (last-total (assq-ref last-gcs 'gc-time-taken)))
+ (display-stat-title "GC time taken:" "diff" "total")
+ (display-time-stat "mark" this-mark last-mark)
+ (display-time-stat "total" this-total last-total)
+ (newline))
+ ;; Process time spent
+ (let ((this-utime (tms:utime this-tms))
+ (last-utime (tms:utime last-tms))
+ (this-stime (tms:stime this-tms))
+ (last-stime (tms:stime last-tms))
+ (this-cutime (tms:cutime this-tms))
+ (last-cutime (tms:cutime last-tms))
+ (this-cstime (tms:cstime this-tms))
+ (last-cstime (tms:cstime last-tms)))
+ (display-stat-title "Process time spent:" "diff" "total")
+ (display-time-stat "user" this-utime last-utime)
+ (display-time-stat "system" this-stime last-stime)
+ (display-time-stat "child user" this-cutime last-cutime)
+ (display-time-stat "child system" this-cstime last-cstime)
+ (newline))
+ ;; VM statistics
+ (let ((this-time (vms:time this-vms))
+ (last-time (vms:time last-vms))
+ (this-clock (vms:clock this-vms))
+ (last-clock (vms:clock last-vms)))
+ (display-stat-title "VM statistics:" "diff" "total")
+ (display-time-stat "time spent" this-time last-time)
+ (display-diff-stat "bogoclock" #f this-clock last-clock "clock")
+ (display-mips-stat "bogomips" this-time this-clock last-time last-clock)
+ (newline))
+ ;; Save statistics
+ ;; Save statistics
+ (set! (repl-tm-stats repl) this-tms)
+ (set! (repl-vm-stats repl) this-vms)
+ (set! (repl-gc-stats repl) this-gcs)))
+
+(define (display-stat title flag field1 field2 unit)
+ (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
+ (format #t str title field1 field2 unit)))
+
+(define (display-stat-title title field1 field2)
+ (display-stat title #t field1 field2 ""))
+
+(define (display-diff-stat title flag this last unit)
+ (display-stat title flag (- this last) this unit))
+
+(define (display-time-stat title this last)
+ (define (conv num)
+ (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second))))
+ (display-stat title #f (conv (- this last)) (conv this) "s"))
+
+(define (display-mips-stat title this-time this-clock last-time last-clock)
+ (define (mips time clock)
+ (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0))))
+ (display-stat title #f
+ (mips (- this-time last-time) (- this-clock last-clock))
+ (mips this-time this-clock) "mips"))
--- /dev/null
+;;; Repl common routines
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl common)
+ :use-syntax (system base syntax)
+ :use-module (system base compile)
+ :use-module (system base language)
+ :use-module (system vm vm)
+ :export (<repl> make-repl repl-vm repl-language repl-options
+ repl-tm-stats repl-gc-stats repl-vm-stats
+ repl-welcome repl-prompt repl-read repl-compile repl-eval
+ repl-print repl-option-ref repl-option-set!
+ puts ->string user-error))
+
+\f
+;;;
+;;; Repl type
+;;;
+
+(define-record (<repl> vm language options tm-stats gc-stats vm-stats))
+
+(define repl-default-options
+ '((trace . #f)))
+
+(define %make-repl make-repl)
+(define (make-repl lang)
+ (%make-repl :vm (the-vm)
+ :language (lookup-language lang)
+ :options repl-default-options
+ :tm-stats (times)
+ :gc-stats (gc-stats)
+ :vm-stats (vm-stats (the-vm))))
+
+(define (repl-welcome repl)
+ (let ((language (repl-language repl)))
+ (format #t "~A interpreter ~A on Guile ~A\n"
+ (language-title language) (language-version language) (version)))
+ (display "Copyright (C) 2001-2008 Free Software Foundation, Inc.\n\n")
+ (display "Enter `,help' for help.\n"))
+
+(define (repl-prompt repl)
+ (format #f "~A@~A> " (language-name (repl-language repl))
+ (module-name (current-module))))
+
+(define (repl-read repl)
+ ((language-reader (repl-language repl))))
+
+(define (repl-compile repl form . opts)
+ (apply compile-in form (current-module) (repl-language repl) opts))
+
+(define (repl-eval repl form)
+ (let ((eval (language-evaluator (repl-language repl))))
+ (if eval
+ (eval form (current-module))
+ (vm-load (repl-vm repl) (repl-compile repl form)))))
+
+(define (repl-print repl val)
+ (if (not (eq? val *unspecified*))
+ (begin
+ ((language-printer (repl-language repl)) val)
+ (newline))))
+
+(define (repl-option-ref repl key)
+ (assq-ref (repl-options repl) key))
+
+(define (repl-option-set! repl key val)
+ (set! (repl-options repl) (assq-set! (repl-options repl) key val)))
+
+\f
+;;;
+;;; Utilities
+;;;
+
+(define (puts x) (display x) (newline))
+
+(define (->string x)
+ (object->string x display))
+
+(define (user-error msg . args)
+ (throw 'user-error #f msg args #f))
--- /dev/null
+;;; Describe objects
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl describe)
+ :use-module (oop goops)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 format)
+ :use-module (ice-9 and-let-star)
+ :export (describe))
+
+(define-method (describe (symbol <symbol>))
+ (format #t "`~s' is " symbol)
+ (if (not (defined? symbol))
+ (display "not defined in the current module.\n")
+ (describe-object (module-ref (current-module) symbol))))
+
+\f
+;;;
+;;; Display functions
+;;;
+
+(define (safe-class-name class)
+ (if (slot-bound? class 'name)
+ (class-name class)
+ class))
+
+(define-method (display-class class . args)
+ (let* ((name (safe-class-name class))
+ (desc (if (pair? args) (car args) name)))
+ (if (eq? *describe-format* 'tag)
+ (format #t "@class{~a}{~a}" name desc)
+ (format #t "~a" desc))))
+
+(define (display-list title list)
+ (if title (begin (display title) (display ":\n\n")))
+ (if (null? list)
+ (display "(not defined)\n")
+ (for-each display-summary list)))
+
+(define (display-slot-list title instance list)
+ (if title (begin (display title) (display ":\n\n")))
+ (if (null? list)
+ (display "(not defined)\n")
+ (for-each (lambda (slot)
+ (let ((name (slot-definition-name slot)))
+ (display "Slot: ")
+ (display name)
+ (if (and instance (slot-bound? instance name))
+ (begin
+ (display " = ")
+ (display (slot-ref instance name))))
+ (newline)))
+ list)))
+
+(define (display-file location)
+ (display "Defined in ")
+ (if (eq? *describe-format* 'tag)
+ (format #t "@location{~a}.\n" location)
+ (format #t "`~a'.\n" location)))
+
+(define (format-documentation doc)
+ (with-current-buffer (make-buffer #:text doc)
+ (lambda ()
+ (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?")))
+ (do-while (match (re-search-forward regexp))
+ (let ((key (string->symbol (match:substring match 1)))
+ (value (match:substring match 3)))
+ (case key
+ ((deffnx)
+ (delete-region! (match:start match)
+ (begin (forward-line) (point))))
+ ((var)
+ (replace-match! match 0 (string-upcase value)))
+ ((code)
+ (replace-match! match 0 (string-append "`" value "'")))))))
+ (display (string (current-buffer)))
+ (newline))))
+
+\f
+;;;
+;;; Top
+;;;
+
+(define description-table
+ (list
+ (cons <boolean> "a boolean")
+ (cons <null> "an empty list")
+ (cons <integer> "an integer")
+ (cons <real> "a real number")
+ (cons <complex> "a complex number")
+ (cons <char> "a character")
+ (cons <symbol> "a symbol")
+ (cons <keyword> "a keyword")
+ (cons <promise> "a promise")
+ (cons <hook> "a hook")
+ (cons <fluid> "a fluid")
+ (cons <stack> "a stack")
+ (cons <variable> "a variable")
+ (cons <regexp> "a regexp object")
+ (cons <module> "a module object")
+ (cons <unknown> "an unknown object")))
+
+(define-generic describe-object)
+(export describe-object)
+
+(define-method (describe-object (obj <top>))
+ (display-type obj)
+ (display-location obj)
+ (newline)
+ (display-value obj)
+ (newline)
+ (display-documentation obj))
+
+(define-generic display-object)
+(define-generic display-summary)
+(define-generic display-type)
+(define-generic display-value)
+(define-generic display-location)
+(define-generic display-description)
+(define-generic display-documentation)
+(export display-object display-summary display-type display-value
+ display-location display-description display-documentation)
+
+(define-method (display-object (obj <top>))
+ (write obj))
+
+(define-method (display-summary (obj <top>))
+ (display "Value: ")
+ (display-object obj)
+ (newline))
+
+(define-method (display-type (obj <top>))
+ (cond
+ ((eof-object? obj) (display "the end-of-file object"))
+ ((unspecified? obj) (display "unspecified"))
+ (else (let ((class (class-of obj)))
+ (display-class class (or (assq-ref description-table class)
+ (safe-class-name class))))))
+ (display ".\n"))
+
+(define-method (display-value (obj <top>))
+ (if (not (unspecified? obj))
+ (begin (display-object obj) (newline))))
+
+(define-method (display-location (obj <top>))
+ *unspecified*)
+
+(define-method (display-description (obj <top>))
+ (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
+ (index (string-index doc #\newline)))
+ (display (make-shared-substring doc 0 (1+ index)))))
+
+(define-method (display-documentation (obj <top>))
+ (display "Not documented.\n"))
+
+\f
+;;;
+;;; Pairs
+;;;
+
+(define-method (display-type (obj <pair>))
+ (cond
+ ((list? obj) (display-class <list> "a list"))
+ ((pair? (cdr obj)) (display "an improper list"))
+ (else (display-class <pair> "a pair")))
+ (display ".\n"))
+
+\f
+;;;
+;;; Strings
+;;;
+
+(define-method (display-type (obj <string>))
+ (if (read-only-string? 'obj)
+ (display "a read-only string")
+ (display-class <string> "a string"))
+ (display ".\n"))
+
+\f
+;;;
+;;; Procedures
+;;;
+
+(define-method (display-object (obj <procedure>))
+ (cond
+ ((closure? obj)
+ ;; Construct output from the source.
+ (display "(")
+ (display (procedure-name obj))
+ (let ((args (cadr (procedure-source obj))))
+ (cond ((null? args) (display ")"))
+ ((pair? args)
+ (let ((str (with-output-to-string (lambda () (display args)))))
+ (format #t " ~a" (string-upcase! (substring str 1)))))
+ (else
+ (format #t " . ~a)" (string-upcase! (symbol->string args)))))))
+ (else
+ ;; Primitive procedure. Let's lookup the dictionary.
+ (and-let* ((entry (lookup-procedure obj)))
+ (let ((name (entry-property entry 'name))
+ (print-arg (lambda (arg)
+ (display " ")
+ (display (string-upcase (symbol->string arg))))))
+ (display "(")
+ (display name)
+ (and-let* ((args (entry-property entry 'args)))
+ (for-each print-arg args))
+ (and-let* ((opts (entry-property entry 'opts)))
+ (display " &optional")
+ (for-each print-arg opts))
+ (and-let* ((rest (entry-property entry 'rest)))
+ (display " &rest")
+ (print-arg rest))
+ (display ")"))))))
+
+(define-method (display-summary (obj <procedure>))
+ (display "Procedure: ")
+ (display-object obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <procedure>))
+ (cond
+ ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
+ ((closure? obj) (display-class <procedure> "a procedure"))
+ ((procedure-with-setter? obj)
+ (display-class <procedure-with-setter> "a procedure with setter"))
+ ((not (struct? obj)) (display "a primitive procedure"))
+ (else (display-class <procedure> "a procedure")))
+ (display ".\n"))
+
+(define-method (display-location (obj <procedure>))
+ (and-let* ((entry (lookup-procedure obj)))
+ (display-file (entry-file entry))))
+
+(define-method (display-documentation (obj <procedure>))
+ (cond ((cond ((closure? obj) (procedure-documentation obj))
+ ((lookup-procedure obj) => entry-text)
+ (else #f))
+ => format-documentation)
+ (else (next-method))))
+
+\f
+;;;
+;;; Classes
+;;;
+
+(define-method (describe-object (obj <class>))
+ (display-type obj)
+ (display-location obj)
+ (newline)
+ (display-documentation obj)
+ (newline)
+ (display-value obj))
+
+(define-method (display-summary (obj <class>))
+ (display "Class: ")
+ (display-class obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <class>))
+ (display-class <class> "a class")
+ (if (not (eq? (class-of obj) <class>))
+ (begin (display " of ") (display-class (class-of obj))))
+ (display ".\n"))
+
+(define-method (display-value (obj <class>))
+ (display-list "Class precedence list" (class-precedence-list obj))
+ (newline)
+ (display-list "Direct superclasses" (class-direct-supers obj))
+ (newline)
+ (display-list "Direct subclasses" (class-direct-subclasses obj))
+ (newline)
+ (display-slot-list "Direct slots" #f (class-direct-slots obj))
+ (newline)
+ (display-list "Direct methods" (class-direct-methods obj)))
+
+\f
+;;;
+;;; Instances
+;;;
+
+(define-method (display-type (obj <object>))
+ (display-class <object> "an instance")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method (display-value (obj <object>))
+ (display-slot-list #f obj (class-slots (class-of obj))))
+
+\f
+;;;
+;;; Generic functions
+;;;
+
+(define-method (display-type (obj <generic>))
+ (display-class <generic> "a generic function")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method (display-value (obj <generic>))
+ (display-list #f (generic-function-methods obj)))
+
+\f
+;;;
+;;; Methods
+;;;
+
+(define-method (display-object (obj <method>))
+ (display "(")
+ (let ((gf (method-generic-function obj)))
+ (display (if gf (generic-function-name gf) "#<anonymous>")))
+ (let loop ((args (method-specializers obj)))
+ (cond
+ ((null? args))
+ ((pair? args)
+ (display " ")
+ (display-class (car args))
+ (loop (cdr args)))
+ (else (display " . ") (display-class args))))
+ (display ")"))
+
+(define-method (display-summary (obj <method>))
+ (display "Method: ")
+ (display-object obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <method>))
+ (display-class <method> "a method")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method (display-documentation (obj <method>))
+ (let ((doc (procedure-documentation (method-procedure obj))))
+ (if doc (format-documentation doc) (next-method))))
--- /dev/null
+;;; Read-Eval-Print Loop
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl repl)
+ :use-syntax (system base syntax)
+ :use-module (system base pmatch)
+ :use-module (system base compile)
+ :use-module (system base language)
+ :use-module (system repl common)
+ :use-module (system repl command)
+ :use-module (system vm vm)
+ :use-module (system vm debug)
+ :use-module (ice-9 rdelim)
+ :export (start-repl call-with-backtrace))
+
+(define meta-command-token (cons 'meta 'command))
+
+(define (meta-reader read)
+ (lambda read-args
+ (with-input-from-port
+ (if (pair? read-args) (car read-args) (current-input-port))
+ (lambda ()
+ (if (eqv? (next-char #t) #\,)
+ (begin (read-char) meta-command-token)
+ (read))))))
+
+;; repl-reader is a function defined in boot-9.scm, and is replaced by
+;; something else if readline has been activated. much of this hoopla is
+;; to be able to re-use the existing readline machinery.
+(define (prompting-meta-read repl)
+ (let ((prompt (lambda () (repl-prompt repl)))
+ (lread (language-reader (repl-language repl))))
+ (with-fluid* current-reader (meta-reader lread)
+ (lambda () (repl-reader (lambda () (repl-prompt repl)))))))
+
+(define (default-pre-unwind-handler key . args)
+ (save-stack default-pre-unwind-handler)
+ (vm-save-stack (the-vm))
+ (apply throw key args))
+
+(define (default-catch-handler . args)
+ (pmatch args
+ ((quit . _)
+ (apply throw args))
+ ((vm-error ,fun ,msg ,args)
+ (vm-backtrace (the-vm))
+ (display "\nVM error: \n")
+ (apply format #t msg args)
+ (newline))
+ ((,key ,subr ,msg ,args . ,rest)
+ (vm-backtrace (the-vm))
+ (newline)
+ (let ((cep (current-error-port)))
+ (cond ((not (stack? (fluid-ref the-last-stack))))
+ ((memq 'backtrace (debug-options-interface))
+ (let ((highlights (if (or (eq? key 'wrong-type-arg)
+ (eq? key 'out-of-range))
+ (car rest)
+ '())))
+ (run-hook before-backtrace-hook)
+ (newline cep)
+ (display "Backtrace:\n")
+ (display-backtrace (fluid-ref the-last-stack) cep
+ #f #f highlights)
+ (newline cep)
+ (run-hook after-backtrace-hook))))
+ (run-hook before-error-hook)
+ (apply display-error (fluid-ref the-last-stack) cep subr msg args rest)
+ (run-hook after-error-hook)
+ (set! stack-saved? #f)
+ (force-output cep)))
+ (else
+ (apply bad-throw args))))
+
+(define (call-with-backtrace thunk)
+ (catch #t
+ thunk
+ default-catch-handler
+ default-pre-unwind-handler))
+
+(eval-case
+ ((compile-toplevel)
+ (define-macro (start-stack tag expr)
+ expr)))
+
+(define (start-repl lang)
+ (let ((repl (make-repl lang)))
+ (repl-welcome repl)
+ (let prompt-loop ()
+ (let ((exp (call-with-backtrace
+ (lambda () (prompting-meta-read repl)))))
+ (cond
+ ((eqv? exp (if #f #f))) ; read error, pass
+ ((eq? exp meta-command-token)
+ (call-with-backtrace
+ (lambda ()
+ (meta-command repl (read-line)))))
+ ((eof-object? exp)
+ (throw 'quit))
+ (else
+ (call-with-backtrace
+ (lambda ()
+ (call-with-values (lambda ()
+ (run-hook before-eval-hook exp)
+ (start-stack repl-eval
+ (repl-eval repl exp)))
+ (lambda l
+ (for-each (lambda (v)
+ (run-hook before-print-hook v)
+ (repl-print repl v))
+ l)))))))
+ (next-char #f) ;; consume trailing whitespace
+ (prompt-loop)))))
+
+(define (next-char wait)
+ (if (or wait (char-ready?))
+ (let ((ch (peek-char)))
+ (cond ((eof-object? ch) (throw 'quit))
+ ((char-whitespace? ch) (read-char) (next-char wait))
+ (else ch)))
+ #f))
--- /dev/null
+Makefile
+Makefile.in
+*.go
--- /dev/null
+SOURCES = assemble.scm conv.scm debug.scm \
+ disasm.scm frame.scm instruction.scm objcode.scm \
+ profile.scm program.scm trace.scm vm.scm
+modpath = system/vm
+include $(top_srcdir)/guilec.mk
--- /dev/null
+;;; Guile VM assembler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm assemble)
+ :use-syntax (system base syntax)
+ :use-module (system il glil)
+ :use-module (system vm instruction)
+ :use-module (system vm objcode)
+ :use-module ((system vm program) :select (make-binding))
+ :use-module (system vm conv)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 common-list)
+ :use-module (srfi srfi-4)
+ :use-module ((srfi srfi-1) :select (append-map))
+ :export (preprocess codegen assemble))
+
+(define (assemble glil env . opts)
+ (codegen (preprocess glil #f) #t))
+
+\f
+;;;
+;;; Types
+;;;
+
+(define-record (<vm-asm> venv glil body))
+(define-record (<venv> parent nexts closure?))
+(define-record (<vlink-now> name))
+(define-record (<vlink-later> module name))
+(define-record (<vdefine> module name))
+(define-record (<bytespec> vars bytes meta objs closure?))
+
+\f
+;;;
+;;; Stage 1: Preprocess
+;;;
+
+(define (preprocess x e)
+ (record-case x
+ ((<glil-asm> vars meta body)
+ (let* ((venv (make-venv :parent e :nexts (glil-vars-nexts vars) :closure? #f))
+ (body (map (lambda (x) (preprocess x venv)) body)))
+ (make-vm-asm :venv venv :glil x :body body)))
+ ((<glil-external> op depth index)
+ (do ((d depth (- d 1))
+ (e e (venv-parent e)))
+ ((= d 0))
+ (set! (venv-closure? e) #t))
+ x)
+ (else x)))
+
+\f
+;;;
+;;; Stage 2: Bytecode generation
+;;;
+
+(define (codegen glil toplevel)
+ (record-case glil
+ ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
+ (let ((stack '())
+ (binding-alist '())
+ (source-alist '())
+ (label-alist '())
+ (object-alist '()))
+ (define (push-code! code)
+; (format #t "push-code! ~a~%" code)
+ (set! stack (cons (code->bytes code) stack)))
+ (define (push-object! x)
+ (cond ((object->code x) => push-code!)
+ (toplevel (dump-object! push-code! x))
+ (else
+ (let ((i (cond ((object-assoc x object-alist) => cdr)
+ (else
+ (let ((i (length object-alist)))
+ (set! object-alist (acons x i object-alist))
+ i)))))
+ (push-code! `(object-ref ,i))))))
+ (define (current-address)
+ (define (byte-length x)
+ (cond ((u8vector? x) (u8vector-length x))
+ (else 3)))
+ (apply + (map byte-length stack)))
+ (define (generate-code x)
+ (record-case x
+ ((<vm-asm> venv)
+ (push-object! (codegen x #f))
+ (if (venv-closure? venv) (push-code! `(make-closure))))
+
+ ((<glil-bind> (binds vars))
+ (let ((bindings
+ (map (lambda (v)
+ (let ((name (car v)) (type (cadr v)) (i (caddr v)))
+ (case type
+ ((argument) (make-binding name #f i))
+ ((local) (make-binding name #f (+ (glil-vars-nargs vars) i)))
+ ((external) (make-binding name #t i)))))
+ binds)))
+ (set! binding-alist
+ (acons (current-address) bindings binding-alist))))
+
+ ((<glil-unbind>)
+ (set! binding-alist (acons (current-address) #f binding-alist)))
+
+ ((<glil-source> loc)
+ (set! source-alist (acons (current-address) loc source-alist)))
+
+ ((<glil-void>)
+ (push-code! '(void)))
+
+ ((<glil-const> obj)
+ (push-object! obj))
+
+ ((<glil-argument> op index)
+ (if (eq? op 'ref)
+ (push-code! `(local-ref ,index))
+ (push-code! `(local-set ,index))))
+
+ ((<glil-local> op index)
+ (if (eq? op 'ref)
+ (push-code! `(local-ref ,(+ (glil-vars-nargs vars) index)))
+ (push-code! `(local-set ,(+ (glil-vars-nargs vars) index)))))
+
+ ((<glil-external> op depth index)
+ (do ((e venv (venv-parent e))
+ (d depth (1- d))
+ (n 0 (+ n (venv-nexts e))))
+ ((= d 0)
+ (if (eq? op 'ref)
+ (push-code! `(external-ref ,(+ n index)))
+ (push-code! `(external-set ,(+ n index)))))))
+
+ ((<glil-module> op module name)
+ (case op
+ ((ref set)
+ (cond
+ (toplevel
+ (push-object! (make-vlink-now :name name))
+ (push-code! (case op
+ ((ref) '(variable-ref))
+ ((set) '(variable-set)))))
+ (else
+ (let* ((var (make-vlink-later :module module :name name))
+ (i (cond ((object-assoc var object-alist) => cdr)
+ (else
+ (let ((i (length object-alist)))
+ (set! object-alist (acons var i object-alist))
+ i)))))
+ (push-code! (case op
+ ((ref) `(late-variable-ref ,i))
+ ((set) `(late-variable-set ,i))))))))
+ ((define)
+ (push-object! (make-vdefine :module module :name name))
+ (push-code! '(variable-set)))
+ (else
+ (error "unknown toplevel var kind" op name))))
+
+ ((<glil-label> label)
+ (set! label-alist (assq-set! label-alist label (current-address))))
+
+ ((<glil-branch> inst label)
+ (set! stack (cons (list inst label) stack)))
+
+ ((<glil-call> inst nargs)
+ (if (instruction? inst)
+ (let ((pops (instruction-pops inst)))
+ (cond ((< pops 0)
+ (push-code! (list inst nargs)))
+ ((= pops nargs)
+ (push-code! (list inst)))
+ (else
+ (error "Wrong number of arguments:" inst nargs))))
+ (error "Unknown instruction:" inst)))))
+ ;;
+ ;; main
+ (for-each generate-code body)
+; (format #t "codegen: stack = ~a~%" (reverse stack))
+ (let ((bytes (stack->bytes (reverse! stack) label-alist)))
+ (if toplevel
+ (bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars))
+ (make-bytespec :vars vars :bytes bytes
+ :meta (if (and (null? binding-alist)
+ (null? source-alist)
+ (null? meta))
+ #f
+ (cons* (reverse! binding-alist)
+ (reverse! source-alist)
+ meta))
+ :objs (let ((objs (map car (reverse! object-alist))))
+ (if (null? objs) #f (list->vector objs)))
+ :closure? (venv-closure? venv))))))))))
+
+(define (object-assoc x alist)
+ (record-case x
+ ((<vlink-now>) (assoc x alist))
+ ((<vlink-later>) (assoc x alist))
+ (else (assq x alist))))
+
+(define (stack->bytes stack label-alist)
+ (let loop ((result '()) (stack stack) (addr 0))
+ (if (null? stack)
+ (list->u8vector(append-map u8vector->list
+ (reverse! result)))
+ (let ((bytes (car stack)))
+ (if (pair? bytes)
+ (let* ((offset (- (assq-ref label-alist (cadr bytes))
+ (+ addr 3)))
+ (n (if (< offset 0) (+ offset 65536) offset)))
+ (set! bytes (code->bytes (list (car bytes)
+ (quotient n 256)
+ (modulo n 256))))))
+ (loop (cons bytes result)
+ (cdr stack)
+ (+ addr (u8vector-length bytes)))))))
+
+\f
+;;;
+;;; Object dump
+;;;
+
+;; NOTE: undumpped in vm_system.c
+
+(define (dump-object! push-code! x)
+ (define (too-long x)
+ (error (string-append x " too long")))
+
+ (let dump! ((x x))
+ (cond
+ ((object->code x) => push-code!)
+ ((record? x)
+ (record-case x
+ ((<bytespec> vars bytes meta objs closure?)
+ ;; dump parameters
+ (let ((nargs (glil-vars-nargs vars)) (nrest (glil-vars-nrest vars))
+ (nlocs (glil-vars-nlocs vars)) (nexts (glil-vars-nexts vars)))
+ (cond
+ ((and (< nargs 4) (< nlocs 8) (< nexts 4))
+ ;; 8-bit representation
+ (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
+ (push-code! `(make-int8 ,x))))
+ ((and (< nargs 16) (< nlocs 128) (< nexts 16))
+ ;; 16-bit representation
+ (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
+ (push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
+ (else
+ ;; Other cases
+ (push-code! (object->code nargs))
+ (push-code! (object->code nrest))
+ (push-code! (object->code nlocs))
+ (push-code! (object->code nexts))
+ (push-code! (object->code #f)))))
+ ;; dump object table
+ (if objs (dump! objs))
+ ;; dump meta data
+ (if meta (dump! meta))
+ ;; dump bytecode
+ (push-code! `(load-program ,bytes)))
+ ((<vlink-later> module name)
+ (dump! (module-name module))
+ (dump! name)
+ (push-code! '(link-later)))
+ ((<vlink-now> name)
+ (dump! name)
+ (push-code! '(link-now)))
+ ((<vdefine> module name)
+ ;; FIXME: dump module
+ (push-code! `(define ,(symbol->string name))))
+ (else
+ (error "assemble: unknown record type" (record-type-descriptor x)))))
+ ((and (integer? x) (exact? x))
+ (let ((str (do ((n x (quotient n 256))
+ (l '() (cons (modulo n 256) l)))
+ ((= n 0)
+ (apply u8vector l)))))
+ (push-code! `(load-integer ,str))))
+ ((number? x)
+ (push-code! `(load-number ,(number->string x))))
+ ((string? x)
+ (push-code! `(load-string ,x)))
+ ((symbol? x)
+ (push-code! `(load-symbol ,(symbol->string x))))
+ ((keyword? x)
+ (push-code! `(load-keyword ,(symbol->string (keyword->symbol x)))))
+ ((list? x)
+ (for-each dump! x)
+ (let ((len (length x)))
+ (if (>= len 65536) (too-long 'list))
+ (push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
+ ((pair? x)
+ (dump! (car x))
+ (dump! (cdr x))
+ (push-code! `(cons)))
+ ((vector? x)
+ (for-each dump! (vector->list x))
+ (let ((len (vector-length x)))
+ (if (>= len 65536) (too-long 'vector))
+ (push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
+ (else
+ (error "assemble: unrecognized object" x)))))
--- /dev/null
+;;; Guile VM code converters
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm conv)
+ :use-module (system vm instruction)
+ :use-module (system base pmatch)
+ :use-module (ice-9 regex)
+ :use-module (srfi srfi-4)
+ :use-module (srfi srfi-1)
+ :export (code-pack code-unpack object->code code->object code->bytes
+ make-byte-decoder))
+
+;;;
+;;; Code compress/decompression
+;;;
+
+(define (code-pack code)
+ (pmatch code
+ ((inst ,n) (guard (integer? n))
+ (cond ((< n 10)
+ (let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
+ (if (instruction? abbrev) (list abbrev) code)))
+ (else code)))
+ (else code)))
+
+(define (code-unpack code)
+ (let ((inst (symbol->string (car code))))
+ (cond
+ ((string-match "^([^:]*):([0-9]+)$" inst) =>
+ (lambda (data)
+ (cons* (string->symbol (match:substring data 1))
+ (string->number (match:substring data 2))
+ (cdr code))))
+ (else code))))
+
+\f
+;;;
+;;; Encoder/decoder
+;;;
+
+(define (object->code x)
+ (cond ((eq? x #t) `(make-true))
+ ((eq? x #f) `(make-false))
+ ((null? x) `(make-eol))
+ ((and (integer? x) (exact? x))
+ (cond ((and (<= -128 x) (< x 128))
+ `(make-int8 ,(modulo x 256)))
+ ((and (<= -32768 x) (< x 32768))
+ (let ((n (if (< x 0) (+ x 65536) x)))
+ `(make-int16 ,(quotient n 256) ,(modulo n 256))))
+ (else #f)))
+ ((char? x) `(make-char8 ,(char->integer x)))
+ (else #f)))
+
+(define (code->object code)
+ (pmatch code
+ ((make-true) #t)
+ ((make-false) #f) ;; FIXME: Same as the `else' case!
+ ((make-eol) '())
+ ((make-int8 ,n)
+ (if (< n 128) n (- n 256)))
+ ((make-int16 ,n1 ,n2)
+ (let ((n (+ (* n1 256) n2)))
+ (if (< n 32768) n (- n 65536))))
+ ((make-char8 ,n)
+ (integer->char n))
+ ((load-string ,s) s)
+ ((load-symbol ,s) (string->symbol s))
+ ((load-keyword ,s) (symbol->keyword (string->symbol s)))
+ (else #f)))
+
+; (let ((c->o code->object))
+; (set! code->object
+; (lambda (code)
+; (format #t "code->object: ~a~%" code)
+; (let ((ret (c->o code)))
+; (format #t "code->object returned ~a~%" ret)
+; ret))))
+
+(define (code->bytes code)
+ (define (string->u8vector str)
+ (apply u8vector (map char->integer (string->list str))))
+
+ (let* ((code (code-pack code))
+ (inst (car code))
+ (rest (cdr code))
+ (len (instruction-length inst))
+ (head (instruction->opcode inst)))
+ (cond ((< len 0)
+ ;; Variable-length code
+ ;; Typical instructions are `link' and `load-program'.
+ (if (string? (car rest))
+ (set-car! rest (string->u8vector (car rest))))
+ (let* ((str (car rest))
+ (str-len (u8vector-length str))
+ (encoded-len (encode-length str-len))
+ (encoded-len-len (u8vector-length encoded-len)))
+ (apply u8vector
+ (append (cons head (u8vector->list encoded-len))
+ (u8vector->list str)))))
+ ((= len (length rest))
+ ;; Fixed-length code
+ (apply u8vector (cons head rest)))
+ (else
+ (error "Invalid code:" code)))))
+
+; (let ((c->b code->bytes))
+; ;; XXX: Debugging output
+; (set! code->bytes
+; (lambda (code)
+; (format #t "code->bytes: ~a~%" code)
+; (let ((result (c->b code)))
+; (format #t "code->bytes: returned ~a~%" result)
+; result))))
+
+
+(define (make-byte-decoder bytes)
+ (let ((addr 0) (size (u8vector-length bytes)))
+ (define (pop)
+ (let ((byte (u8vector-ref bytes addr)))
+ (set! addr (1+ addr))
+ byte))
+ (define (sublist lst start end)
+ (take (drop lst start) (- end start)))
+ (lambda ()
+ (if (< addr size)
+ (let* ((start addr)
+ (inst (opcode->instruction (pop)))
+ (n (instruction-length inst))
+ (code (if (< n 0)
+ ;; variable length
+ (let* ((end (+ (decode-length pop) addr))
+ (subbytes (sublist
+ (u8vector->list bytes)
+ addr end))
+ (->string? (not (eq? inst 'load-program))))
+ (set! addr end)
+ (list inst
+ (if ->string?
+ (list->string
+ (map integer->char subbytes))
+ (apply u8vector subbytes))))
+ ;; fixed length
+ (do ((n n (1- n))
+ (l '() (cons (pop) l)))
+ ((= n 0) (cons* inst (reverse! l)))))))
+ (values start code))
+ #f))))
+
+\f
+;;;
+;;; Variable-length interface
+;;;
+
+;; NOTE: decoded in vm_fetch_length in vm.c as well.
+
+(define (encode-length len)
+ (cond ((< len 254) (u8vector len))
+ ((< len (* 256 256))
+ (u8vector 254 (quotient len 256) (modulo len 256)))
+ ((< len most-positive-fixnum)
+ (u8vector 255
+ (quotient len (* 256 256 256))
+ (modulo (quotient len (* 256 256)) 256)
+ (modulo (quotient len 256) 256)
+ (modulo len 256)))
+ (else (error "Too long code length:" len))))
+
+(define (decode-length pop)
+ (let ((len (pop)))
+ (cond ((< len 254) len)
+ ((= len 254) (+ (* (pop) 256) (pop)))
+ (else (+ (* (pop) 256 256 256)
+ (* (pop) 256 256)
+ (* (pop) 256)
+ (pop))))))
--- /dev/null
+;;; Guile VM debugging facilities
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm debug)
+ :use-syntax (system base syntax)
+ :use-module (system vm vm)
+ :use-module (system vm frame)
+ :use-module (ice-9 format)
+ :export (vm-debugger vm-backtrace))
+
+\f
+;;;
+;;; Debugger
+;;;
+
+(define-record (<debugger> vm chain index))
+
+(define (vm-debugger vm)
+ (let ((chain (vm-last-frame-chain vm)))
+ (if (null? chain)
+ (display "Nothing to debug\n")
+ (debugger-repl (make-debugger
+ :vm vm :chain chain :index (length chain))))))
+
+(define (debugger-repl db)
+ (let loop ()
+ (display "debug> ")
+ (let ((cmd (read)))
+ (case cmd
+ ((bt) (vm-backtrace (debugger-vm db)))
+ ((stack)
+ (write (vm-fetch-stack (debugger-vm db)))
+ (newline))
+ (else
+ (format #t "Unknown command: ~A" cmd))))))
+
+\f
+;;;
+;;; Backtrace
+;;;
+
+(define (vm-backtrace vm)
+ (print-frame-chain-as-backtrace
+ (reverse (vm-last-frame-chain vm))))
--- /dev/null
+;;; Guile VM Disassembler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm disasm)
+ :use-module (system base pmatch)
+ :use-module (system vm objcode)
+ :use-module (system vm program)
+ :use-module (system vm conv)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 format)
+ :use-module (ice-9 receive)
+ :export (disassemble-objcode disassemble-program disassemble-bytecode))
+
+(define (disassemble-objcode objcode . opts)
+ (let* ((prog (objcode->program objcode))
+ (arity (program-arity prog))
+ (nlocs (arity:nlocs arity))
+ (nexts (arity:nexts arity))
+ (bytes (program-bytecode prog)))
+ (format #t "Disassembly of ~A:\n\n" objcode)
+ (format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts)
+ (disassemble-bytecode bytes #f)))
+
+(define (disassemble-program prog . opts)
+ (let* ((arity (program-arity prog))
+ (nargs (arity:nargs arity))
+ (nrest (arity:nrest arity))
+ (nlocs (arity:nlocs arity))
+ (nexts (arity:nexts arity))
+ (bytes (program-bytecode prog))
+ (objs (program-objects prog))
+ (meta (program-meta prog))
+ (exts (program-external prog)))
+ ;; Disassemble this bytecode
+ (format #t "Disassembly of ~A:\n\n" prog)
+ (format #t "nargs = ~A nrest = ~A nlocs = ~A nexts = ~A\n\n"
+ nargs nrest nlocs nexts)
+ (format #t "Bytecode:\n\n")
+ (disassemble-bytecode bytes objs)
+ (if (> (vector-length objs) 0)
+ (disassemble-objects objs))
+ (if (pair? exts)
+ (disassemble-externals exts))
+ (if meta
+ (disassemble-meta meta))
+ ;; Disassemble other bytecode in it
+ (for-each
+ (lambda (x)
+ (if (program? x)
+ (begin (display "----------------------------------------\n")
+ (apply disassemble-program x opts))))
+ (vector->list objs))))
+
+(define (disassemble-bytecode bytes objs)
+ (let ((decode (make-byte-decoder bytes))
+ (programs '()))
+ (do ((addr+code (decode) (decode)))
+ ((not addr+code) (newline))
+ (receive (addr code) addr+code
+ (pmatch code
+ ((load-program ,x)
+ (let ((sym (gensym "")))
+ (set! programs (acons sym x programs))
+ (print-info addr (format #f "(load-program #~A)" sym) #f)))
+ (else
+ (let ((info (list->info code))
+ (extra (original-value addr code objs)))
+ (print-info addr info extra))))))
+ (for-each (lambda (sym+bytes)
+ (format #t "Bytecode #~A:\n\n" (car sym+bytes))
+ (disassemble-bytecode (cdr sym+bytes) #f))
+ (reverse! programs))))
+
+(define (disassemble-objects objs)
+ (display "Objects:\n\n")
+ (let ((len (vector-length objs)))
+ (do ((n 0 (1+ n)))
+ ((= n len) (newline))
+ (let ((info (object->string (vector-ref objs n))))
+ (print-info n info #f)))))
+
+(define (disassemble-externals exts)
+ (display "Externals:\n\n")
+ (let ((len (length exts)))
+ (do ((n 0 (1+ n))
+ (l exts (cdr l)))
+ ((null? l) (newline))
+ (let ((info (object->string (car l))))
+ (print-info n info #f)))))
+
+(define-macro (unless test . body)
+ `(if (not ,test) (begin ,@body)))
+
+(define (disassemble-meta meta)
+ (let ((bindings (car meta))
+ (sources (cadr meta))
+ (props (cddr meta)))
+ (unless (null? bindings)
+ (display "Bindings:\n\n")
+ (for-each (lambda (b)
+ (print-info (car b) (list->info (cadr b)) #f))
+ bindings)
+ (newline))
+ (unless (null? sources)
+ (display "Sources:\n\n")
+ (for-each (lambda (x)
+ (print-info (car x) (list->info (cdr x)) #f))
+ sources)
+ (newline))
+ (unless (null? props)
+ (display "Properties:\n\n")
+ (for-each (lambda (x) (print-info #f x #f)) props)
+ (newline))))
+
+(define (original-value addr code objs)
+ (define (branch-code? code)
+ (string-match "^br" (symbol->string (car code))))
+ (define (list-or-vector? code)
+ (case (car code)
+ ((list vector) #t)
+ (else #f)))
+
+ (let ((code (code-unpack code)))
+ (cond ((list-or-vector? code)
+ (let ((len (+ (* (cadr code) 256) (caddr code))))
+ (format #f "~a element~a" len (if (> len 1) "s" ""))))
+ ((code->object code) => object->string)
+ ((branch-code? code)
+ (let ((offset (+ (* (cadr code) 256) (caddr code))))
+ (format #f "-> ~A" (+ addr offset 3))))
+ (else
+ (let ((inst (car code)) (args (cdr code)))
+ (case inst
+ ((make-false) "#f")
+ ((object-ref)
+ (if objs (object->string (vector-ref objs (car args))) #f))
+ (else #f)))))))
+
+(define (list->info list)
+ (object->string list))
+
+; (define (u8vector->string vec)
+; (list->string (map integer->char (u8vector->list vec))))
+
+; (case (car list)
+; ((link)
+; (object->string `(link ,(u8vector->string (cadr list)))))
+; (else
+; (object->string list))))
+
+(define (print-info addr info extra)
+ (if extra
+ (format #t "~4@A ~32A;; ~A\n" addr info extra)
+ (format #t "~4@A ~A\n" addr info)))
+
+(define (simplify x)
+ (cond ((string? x)
+ (cond ((string-index x #\newline) =>
+ (lambda (i) (set! x (substring x 0 i)))))
+ (cond ((> (string-length x) 16)
+ (set! x (string-append (substring x 0 13) "..."))))))
+ x)
--- /dev/null
+;;; Guile VM frame functions
+
+;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm frame)
+ :use-module (system vm program)
+ :use-module (system vm instruction)
+ :use-module ((srfi srfi-1) :select (fold))
+ :export (frame-number frame-address
+ make-frame-chain
+ print-frame print-frame-chain-as-backtrace
+ frame-arguments frame-local-variables frame-external-variables
+ frame-environment
+ frame-variable-exists? frame-variable-ref frame-variable-set!
+ frame-object-name
+ frame-local-ref frame-external-link frame-local-set!
+ frame-return-address frame-program
+ frame-dynamic-link heap-frame?))
+
+;; fixme: avoid the dynamic-call?
+(dynamic-call "scm_init_frames" (dynamic-link "libguile"))
+
+;;;
+;;; Frame chain
+;;;
+
+(define frame-number (make-object-property))
+(define frame-address (make-object-property))
+
+(define (bootstrap-frame? frame)
+ (let ((code (program-bytecode (frame-program frame))))
+ (and (= (uniform-vector-length code) 3)
+ (= (uniform-vector-ref code 2)
+ (instruction->opcode 'halt)))))
+
+(define (make-frame-chain frame addr)
+ (define (make-rest)
+ (make-frame-chain (frame-dynamic-link frame)
+ (frame-return-address frame)))
+ (cond
+ ((or (eq? frame #t) (eq? frame #f))
+ ;; handle #f or #t dynamic links
+ '())
+ ((bootstrap-frame? frame)
+ (make-rest))
+ (else
+ (let ((chain (make-rest)))
+ (set! (frame-number frame) (length chain))
+ (set! (frame-address frame)
+ (- addr (program-base (frame-program frame))))
+ (cons frame chain)))))
+
+\f
+;;;
+;;; Pretty printing
+;;;
+
+(define (frame-line-number frame)
+ (let ((addr (frame-address frame)))
+ (cond ((assv addr (program-sources (frame-program frame)))
+ => source:line)
+ (else (format #f "@~a" addr)))))
+
+(define (frame-file frame prev)
+ (let ((sources (program-sources (frame-program frame))))
+ (if (null? sources)
+ prev
+ (or (source:file (car sources))
+ "current input"))))
+
+(define (print-frame frame)
+ (format #t "~4@a: ~a ~s\n" (frame-line-number frame) (frame-number frame)
+ (frame-call-representation frame)))
+
+
+(define (frame-call-representation frame)
+ (define (abbrev x)
+ (cond ((list? x)
+ (if (> (length x) 3)
+ (list (abbrev (car x)) (abbrev (cadr x)) '...)
+ (map abbrev x)))
+ ((pair? x)
+ (cons (abbrev (car x)) (abbrev (cdr x))))
+ ((vector? x)
+ (case (vector-length x)
+ ((0) x)
+ ((1) (vector (abbrev (vector-ref x 0))))
+ (else (vector (abbrev (vector-ref x 0)) '...))))
+ (else x)))
+ (abbrev (cons (program-name frame) (frame-arguments frame))))
+
+(define (print-frame-chain-as-backtrace frames)
+ (if (null? frames)
+ (format #t "No backtrace available.\n")
+ (begin
+ (format #t "VM backtrace:\n")
+ (fold (lambda (frame file)
+ (let ((new-file (frame-file frame file)))
+ (if (not (equal? new-file file))
+ (format #t "In ~a:\n" new-file))
+ (print-frame frame)
+ new-file))
+ 'no-file
+ frames))))
+
+(define (program-name frame)
+ (let ((prog (frame-program frame))
+ (link (frame-dynamic-link frame)))
+ (or (object-property prog 'name)
+ (and (heap-frame? link)
+ (frame-object-name link (1- (frame-address link)) prog))
+ (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
+ prog (module-obarray (current-module))))))
+
+\f
+;;;
+;;; Frames
+;;;
+
+(define (frame-arguments frame)
+ (let* ((prog (frame-program frame))
+ (arity (program-arity prog)))
+ (do ((n (+ (arity:nargs arity) -1) (1- n))
+ (l '() (cons (frame-local-ref frame n) l)))
+ ((< n 0) l))))
+
+(define (frame-local-variables frame)
+ (let* ((prog (frame-program frame))
+ (arity (program-arity prog)))
+ (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
+ (l '() (cons (frame-local-ref frame n) l)))
+ ((< n 0) l))))
+
+(define (frame-external-variables frame)
+ (frame-external-link frame))
+
+(define (frame-external-ref frame index)
+ (list-ref (frame-external-link frame) index))
+
+(define (frame-external-set! frame index val)
+ (list-set! (frame-external-link frame) index val))
+
+(define (frame-binding-ref frame binding)
+ (if (binding:extp binding)
+ (frame-external-ref frame (binding:index binding))
+ (frame-local-ref frame (binding:index binding))))
+
+(define (frame-binding-set! frame binding val)
+ (if (binding:extp binding)
+ (frame-external-set! frame (binding:index binding) val)
+ (frame-local-set! frame (binding:index binding) val)))
+
+(define (frame-bindings frame addr)
+ (do ((bs (program-bindings (frame-program frame)) (cdr bs))
+ (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
+ ((or (null? bs) (> (caar bs) addr))
+ (apply append ls))))
+
+(define (frame-lookup-binding frame addr sym)
+ (do ((bs (frame-bindings frame addr) (cdr bs)))
+ ((or (null? bs) (eq? sym (binding:name (car bs))))
+ (and (pair? bs) (car bs)))))
+
+(define (frame-object-binding frame addr obj)
+ (do ((bs (frame-bindings frame addr) (cdr bs)))
+ ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
+ (and (pair? bs) (car bs)))))
+
+(define (frame-environment frame addr)
+ (map (lambda (binding)
+ (cons (binding:name binding) (frame-binding-ref frame binding)))
+ (frame-bindings frame addr)))
+
+(define (frame-variable-exists? frame addr sym)
+ (if (frame-lookup-binding frame addr sym) #t #f))
+
+(define (frame-variable-ref frame addr sym)
+ (cond ((frame-lookup-binding frame addr sym) =>
+ (lambda (binding) (frame-binding-ref frame binding)))
+ (else (error "Unknown variable:" sym))))
+
+(define (frame-variable-set! frame addr sym val)
+ (cond ((frame-lookup-binding frame addr sym) =>
+ (lambda (binding) (frame-binding-set! frame binding val)))
+ (else (error "Unknown variable:" sym))))
+
+(define (frame-object-name frame addr obj)
+ (cond ((frame-object-binding frame addr obj) => binding:name)
+ (else #f)))
--- /dev/null
+;;; Guile VM instructions
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm instruction)
+ :export (instruction-list
+ instruction? instruction-length
+ instruction-pops instruction-pushes
+ instruction->opcode opcode->instruction))
+
+(dynamic-call "scm_init_instructions" (dynamic-link "libguile"))
--- /dev/null
+;;; Guile VM object code
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm objcode)
+ :export (objcode->u8vector objcode? objcode->program bytecode->objcode
+ load-objcode))
+
+(dynamic-call "scm_init_objcodes" (dynamic-link "libguile"))
--- /dev/null
+;;; Guile VM profiler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm profile)
+ :use-module (system vm vm)
+ :use-module (ice-9 format)
+ :export (vm-profile))
+
+(define (vm-profile vm objcode . opts)
+ (let ((flag (vm-option vm 'debug)))
+ (dynamic-wind
+ (lambda ()
+ (set-vm-option! vm 'debug #t)
+ (set-vm-option! vm 'profile-data '())
+ (add-hook! (vm-next-hook vm) profile-next)
+ (add-hook! (vm-enter-hook vm) profile-enter)
+ (add-hook! (vm-exit-hook vm) profile-exit))
+ (lambda ()
+ (vm-load vm objcode)
+ (print-result vm))
+ (lambda ()
+ (set-vm-option! vm 'debug flag)
+ (remove-hook! (vm-next-hook vm) profile-next)
+ (remove-hook! (vm-enter-hook vm) profile-enter)
+ (remove-hook! (vm-exit-hook vm) profile-exit)))))
+
+(define (profile-next vm)
+ (set-vm-option! vm 'profile-data
+ (cons (vm-fetch-code vm) (vm-option vm 'profile-data))))
+
+(define (profile-enter vm)
+ #f)
+
+(define (profile-exit vm)
+ #f)
+
+(define (print-result vm . opts)
+ (do ((data (vm-option vm 'profile-data) (cdr data))
+ (summary '() (let ((inst (caar data)))
+ (assq-set! summary inst
+ (1+ (or (assq-ref summary inst) 0))))))
+ ((null? data)
+ (display "Count Instruction\n")
+ (display "----- -----------\n")
+ (for-each (lambda (entry)
+ (format #t "~5@A ~A\n" (cdr entry) (car entry)))
+ (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2))))))))
--- /dev/null
+;;; Guile VM program functions
+
+;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm program)
+ :export (arity:nargs arity:nrest arity:nlocs arity:nexts
+ make-binding binding:name binding:extp binding:index
+ source:addr source:line source:column source:file
+ program-bindings program-sources
+ program-properties program-property program-documentation
+
+ program-arity program-external-set! program-meta
+ program-bytecode program? program-objects
+ program-base program-external))
+
+(dynamic-call "scm_init_programs" (dynamic-link "libguile"))
+
+(define arity:nargs car)
+(define arity:nrest cadr)
+(define arity:nlocs caddr)
+(define arity:nexts cadddr)
+
+(define (make-binding name extp index)
+ (list name extp index))
+
+(define binding:name car)
+(define binding:extp cadr)
+(define binding:index caddr)
+
+(define (program-bindings prog)
+ (cond ((program-meta prog) => car)
+ (else '())))
+
+(define (source:addr source)
+ (car source))
+(define (source:line source)
+ (vector-ref (cdr source) 0))
+(define (source:column source)
+ (vector-ref (cdr source) 1))
+(define (source:file source)
+ (vector-ref (cdr source) 2))
+
+(define (program-sources prog)
+ (cond ((program-meta prog) => cadr)
+ (else '())))
+
+(define (program-properties prog)
+ (or (and=> (program-meta prog) cddr)
+ '()))
+
+(define (program-property prog prop)
+ (assq-ref (program-properties proc) prop))
+
+(define (program-documentation prog)
+ (assq-ref (program-properties prog) 'documentation))
+
--- /dev/null
+;;; Guile VM tracer
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm trace)
+ :use-syntax (system base syntax)
+ :use-module (system vm vm)
+ :use-module (system vm frame)
+ :use-module (ice-9 format)
+ :export (vm-trace vm-trace-on vm-trace-off))
+
+(define (vm-trace vm objcode . opts)
+ (dynamic-wind
+ (lambda () (apply vm-trace-on vm opts))
+ (lambda () (vm-load vm objcode))
+ (lambda () (apply vm-trace-off vm opts))))
+
+(define (vm-trace-on vm . opts)
+ (set-vm-option! vm 'trace-first #t)
+ (if (memq :b opts) (add-hook! (vm-next-hook vm) trace-next))
+ (set-vm-option! vm 'trace-options opts)
+ (add-hook! (vm-apply-hook vm) trace-apply)
+ (add-hook! (vm-return-hook vm) trace-return))
+
+(define (vm-trace-off vm . opts)
+ (if (memq :b opts) (remove-hook! (vm-next-hook vm) trace-next))
+ (remove-hook! (vm-apply-hook vm) trace-apply)
+ (remove-hook! (vm-return-hook vm) trace-return))
+
+(define (trace-next vm)
+ (define (puts x) (display #\tab) (write x))
+ (define (truncate! x n)
+ (if (> (length x) n)
+ (list-cdr-set! x (1- n) '(...))) x)
+ ;; main
+ (format #t "0x~8X ~16S" (vm:ip vm) (vm-fetch-code vm))
+ (do ((opts (vm-option vm 'trace-options) (cdr opts)))
+ ((null? opts) (newline))
+ (case (car opts)
+ ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
+ ((:l) (puts (vm-fetch-locals vm)))
+ ((:e) (puts (vm-fetch-externals vm))))))
+
+(define (trace-apply vm)
+ (if (vm-option vm 'trace-first)
+ (set-vm-option! vm 'trace-first #f)
+ (let ((chain (vm-current-frame-chain vm)))
+ (print-indent chain)
+ (print-frame-call (car chain))
+ (newline))))
+
+(define (trace-return vm)
+ (let ((chain (vm-current-frame-chain vm)))
+ (print-indent chain)
+ (write (vm-return-value vm))
+ (newline)))
+
+(define (print-indent chain)
+ (cond ((pair? (cdr chain))
+ (display "| ")
+ (print-indent (cdr chain)))))
--- /dev/null
+;;; Guile VM core
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm vm)
+ :use-module (system vm frame)
+ :use-module (system vm objcode)
+ :export (vm? the-vm make-vm vm-version
+ vm:ip vm:sp vm:fp vm:last-ip
+
+ vm-load vm-return-value
+
+ vm-option set-vm-option! vm-version
+
+ vm-fetch-locals vm-fetch-externals
+ vm-last-frame vm-this-frame vm-fetch-stack vm-save-stack
+ vm-current-frame-chain vm-last-frame-chain
+
+ vm-stats vms:time vms:clock
+
+ vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
+ vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
+
+(dynamic-call "scm_init_vm" (dynamic-link "libguile"))
+
+(define (vm-current-frame-chain vm)
+ (make-frame-chain (vm-this-frame vm) (vm:ip vm)))
+
+(define (vm-last-frame-chain vm)
+ (make-frame-chain (vm-last-frame vm) (vm:last-ip vm)))
+
+(define (vm-fetch-locals vm)
+ (frame-local-variables (vm-this-frame vm)))
+
+(define (vm-fetch-externals vm)
+ (frame-external-variables (vm-this-frame vm)))
+
+(define (vm-return-value vm)
+ (car (vm-fetch-stack vm)))
+
+(define (vms:time stat) (vector-ref stat 0))
+(define (vms:clock stat) (vector-ref stat 1))
+
+(define (vm-load vm objcode)
+ (vm (objcode->program objcode)))
# Example: ../../pre-inst-guile-env ./guile-test-foo
# config
-subdirs_with_ltlibs="srfi guile-readline" # maintain me
+subdirs_with_ltlibs="srfi guile-readline libguile" # maintain me
# env (set by configure)
top_srcdir="@top_srcdir_absolute@"
if [ x"$GUILE_LOAD_PATH" = x ]
then
- GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}"
+ if test "${top_srcdir}" != "${top_builddir}"; then
+ GUILE_LOAD_PATH="${top_builddir}/guile-readline:${top_srcdir}/guile-readline:${top_builddir}:${top_srcdir}:${top_builddir}/module:${top_srcdir}/module"
+ else
+ GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}:${top_builddir}/module:${top_srcdir}/module"
+ fi
else
- for d in "${top_srcdir}" "${top_srcdir}/guile-readline"
+ for d in "${top_srcdir}" "${top_srcdir}/guile-readline" \
+ "${top_srcdir}/module" "${top_builddir}/module"
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
# to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
# Floor, Boston, MA 02110-1301 USA
-# NOTE: at some point we might consider invoking this under
-# pre-inst-guile-env. If this will work, then most of the code below
-# can be removed.
-
-# NOTE: If you update this file, please update pre-inst-guile-env.in
-# as well, if appropriate.
-
# Commentary:
# Usage: pre-inst-guile [ARGS]
# Code:
-# config
-subdirs_with_ltlibs="srfi guile-readline libguile" # maintain me
-
# env (set by configure)
-top_srcdir="@top_srcdir_absolute@"
top_builddir="@top_builddir_absolute@"
-[ x"$top_srcdir" = x -o ! -d "$top_srcdir" -o \
- x"$top_builddir" = x -o ! -d "$top_builddir" ] && {
- echo $0: bad environment
- echo top_srcdir=$top_srcdir
- echo top_builddir=$top_builddir
- exit 1
-}
-
-# handle GUILE_LOAD_PATH (no clobber)
-if [ x"$GUILE_LOAD_PATH" = x ]
-then
- GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}"
-else
- for d in "${top_srcdir}" "${top_srcdir}/guile-readline"
- do
- # This hair prevents double inclusion.
- # The ":" prevents prefix aliasing.
- case x"$GUILE_LOAD_PATH" in
- x*${d}:*) ;;
- *) GUILE_LOAD_PATH="${d}:$GUILE_LOAD_PATH" ;;
- esac
- done
-fi
-export GUILE_LOAD_PATH
-
-# handle LTDL_LIBRARY_PATH (no clobber)
-ltdl_prefix=""
-dyld_prefix=""
-for dir in $subdirs_with_ltlibs ; do
- ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}"
- dyld_prefix="${top_builddir}/${dir}/.libs:${dyld_prefix}"
-done
-LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH"
-export LTDL_LIBRARY_PATH
-DYLD_LIBRARY_PATH="${dyld_prefix}${top_builddir}/libguile/.libs:$DYLD_LIBRARY_PATH"
-export DYLD_LIBRARY_PATH
-
# set GUILE (clobber)
GUILE=${top_builddir}/libguile/guile
export GUILE
# do it
-exec $GUILE "$@"
+exec ${top_builddir}/pre-inst-guile-env $GUILE "$@"
# never reached
exit 1
--- /dev/null
+.libs
+.deps
+guilec
+guile-vm
+stamp-h
+config.h
+config.h.in
+stamp-h.in
+Makefile
+Makefile.in
+*.x
+*.i
+*.lo
+*.la
--- /dev/null
+bin_SCRIPTS = guilec guile-disasm
+%: %.in
+ sed "s!@guile@!$(bindir)/guile!" $^ > $@
+ @chmod 755 $@
--- /dev/null
+#!@guile@ -s
+!#
+
+;; Obviously, this is -*- Scheme -*-.
+
+(use-modules (system vm core)
+ (system vm disasm))
+
+(for-each (lambda (file)
+ (disassemble-objcode (load-objcode file)))
+ (cdr (command-line)))
--- /dev/null
+#!@guile@ -s
+# -*- Scheme -*-
+!#
+;;; guilec -- Command-line Guile Scheme compiler.
+;;;
+;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+(use-modules (system base compile)
+ (ice-9 getopt-long))
+
+(read-set! keywords 'prefix)
+
+(define %guilec-options
+ '((help (single-char #\h) (value #f))
+ (optimize (single-char #\O) (value #f))
+ (expand-only (single-char #\e) (value #f))
+ (translate-only (single-char #\t) (value #f))
+ (compile-only (single-char #\c) (value #f))))
+
+(let* ((options (getopt-long (command-line) %guilec-options))
+ (help? (option-ref options 'help #f))
+ (optimize? (option-ref options 'optimize #f))
+ (expand-only? (option-ref options 'expand-only #f))
+ (translate-only? (option-ref options 'translate-only #f))
+ (compile-only? (option-ref options 'compile-only #f)))
+ (if help?
+ (begin
+ (format #t "Usage: guilec [OPTION] FILE...
+Compile each Guile Scheme source file FILE into a Guile object.
+
+ -h, --help print this help message
+ -O, --optimize turn on optimizations
+ -e, --expand-only only go through the code expansion stage
+ -t, --translate-only stop after the translation to GHIL
+ -c, --compile-only stop after the compilation to GLIL
+
+Report bugs to <guile-user@gnu.org>.~%")
+ (exit 0)))
+
+ (let ((compile-opts (append (if optimize? '(:O) '())
+ (if expand-only? '(:e) '())
+ (if translate-only? '(:t) '())
+ (if compile-only? '(:c) '()))))
+
+ (catch #t
+ (lambda ()
+ (for-each (lambda (file)
+ (apply compile-file (cons file compile-opts)))
+ (option-ref options '() '())))
+ (lambda (key . args)
+ (format (current-error-port) "exception `~a' caught~a~%" key
+ (if (null? args) ""
+ (if (string? (car args))
+ (string-append " in subr `" (car args) "'")
+ "")))
+
+ (format (current-error-port) "removing compiled files due to errors~%")
+ (false-if-exception
+ (for-each unlink (map compiled-file-name files)))
+ (exit 1)))))
--- /dev/null
+# The test programs.
+
+# The Libtool executable.
+GUILE_VM = $(top_builddir)/pre-inst-guile
+
+vm_test_files = \
+ t-basic-contructs.scm \
+ t-global-bindings.scm \
+ t-catch.scm \
+ t-closure.scm \
+ t-closure2.scm \
+ t-closure3.scm \
+ t-do-loop.scm \
+ t-macros.scm \
+ t-macros2.scm \
+ t-map.scm \
+ t-or.scm \
+ t-proc-with-setter.scm \
+ t-values.scm \
+ t-records.scm \
+ t-match.scm \
+ t-mutual-toplevel-defines.scm
+
+EXTRA_DIST = run-vm-tests.scm $(vm_test_files)
+
+
+check:
+ $(top_builddir)/pre-inst-guile-env $(GUILE_VM) \
+ -L $(top_srcdir)/module \
+ -l run-vm-tests.scm -e run-vm-tests \
+ $(vm_test_files)
--- /dev/null
+;;; run-vm-tests.scm -- Run Guile-VM's test suite.
+;;;
+;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(use-modules (system vm vm)
+ (system vm disasm)
+ (system base compile)
+ (system base language)
+
+ (srfi srfi-1)
+ (ice-9 r5rs))
+
+\f
+(define %scheme (lookup-language 'scheme))
+
+(define (fetch-sexp-from-file file)
+ (with-input-from-file file
+ (lambda ()
+ (let loop ((sexp (read))
+ (result '()))
+ (if (eof-object? sexp)
+ (cons 'begin (reverse result))
+ (loop (read) (cons sexp result)))))))
+
+(define (compile-to-objcode sexp)
+ "Compile the expression @var{sexp} into a VM program and return it."
+ (compile-in sexp (current-module) %scheme))
+
+(define (run-vm-program objcode)
+ "Run VM program contained into @var{objcode}."
+ (vm-load (the-vm) objcode))
+
+(define (compile/run-test-from-file file)
+ "Run test from source file @var{file} and return a value indicating whether
+it succeeded."
+ (run-vm-program (compile-to-objcode (fetch-sexp-from-file file))))
+
+\f
+(define-macro (watch-proc proc-name str)
+ `(let ((orig-proc ,proc-name))
+ (set! ,proc-name
+ (lambda args
+ (format #t (string-append ,str "... "))
+ (apply orig-proc args)))))
+
+(watch-proc fetch-sexp-from-file "reading")
+(watch-proc compile-to-objcode "compiling")
+(watch-proc run-vm-program "running")
+
+\f
+;; The program.
+
+(define (run-vm-tests files)
+ "For each file listed in @var{files}, load it and run it through both the
+interpreter and the VM (after having it compiled). Both results must be
+equal in the sense of @var{equal?}."
+ (let* ((res (map (lambda (file)
+ (format #t "running `~a'... " file)
+ (if (catch #t
+ (lambda ()
+ (equal? (compile/run-test-from-file file)
+ (eval (fetch-sexp-from-file file)
+ (interaction-environment))))
+ (lambda (key . args)
+ (format #t "[~a/~a] " key args)
+ #f))
+ (format #t "ok~%")
+ (begin (format #t "FAILED~%") #f)))
+ files))
+ (total (length files))
+ (failed (length (filter not res))))
+
+ (if (= 0 failed)
+ (begin
+ (format #t "~%All ~a tests passed~%" total)
+ (exit 0))
+ (begin
+ (format #t "~%~a tests failed out of ~a~%"
+ failed total)
+ (exit failed)))))
+
--- /dev/null
+;;; Basic RnRS constructs.
+
+(and (eq? 2 (begin (+ 2 4) 5 2))
+ ((lambda (x y)
+ (and (eq? x 1) (eq? y 2)
+ (begin
+ (set! x 11) (set! y 22)
+ (and (eq? x 11) (eq? y 22)))))
+ 1 2)
+ (let ((x 1) (y 3))
+ (and (eq? x 1) (eq? y 3)))
+ (let loop ((x #t))
+ (if (not x)
+ #t
+ (loop #f))))
+
--- /dev/null
+;; Test that nonlocal exits of the VM work.
+
+(begin
+ (define (foo thunk)
+ (catch #t thunk (lambda args args)))
+ (foo
+ (lambda ()
+ (let ((a 'one))
+ (1+ a)))))
+
--- /dev/null
+(define func
+ (let ((x 2))
+ (lambda ()
+ (let ((x++ (+ 1 x)))
+ (set! x x++)
+ x++))))
+
+(list (func) (func) (func))
--- /dev/null
+
+(define (uid)
+ (let* ((x 2)
+ (do-uid (lambda ()
+ (let ((x++ (+ 1 x)))
+ (set! x x++)
+ x++))))
+ (do-uid)))
+
+(list (uid) (uid) (uid))
--- /dev/null
+(define (stuff)
+ (let* ((x 2)
+ (chbouib (lambda (z)
+ (+ 7 z x))))
+ (chbouib 77)))
+
+(stuff)
--- /dev/null
+(let ((n+ 0))
+ (do ((n- 5 (1- n-))
+ (n+ n+ (1+ n+)))
+ ((= n- 0))
+ (format #f "n- = ~a~%" n-)))
--- /dev/null
+;; Are global bindings reachable at run-time? This relies on the
+;; `object-ref' and `object-set' instructions.
+
+(begin
+
+ (define the-binding "hello")
+
+ ((lambda () the-binding))
+
+ ((lambda () (set! the-binding "world")))
+
+ ((lambda () the-binding)))
+
--- /dev/null
+;; Are built-in macros well-expanded at compilation-time?
+
+(false-if-exception (+ 2 2))
+(read-options)
--- /dev/null
+;; Are macros well-expanded at compilation-time?
+
+(defmacro minus-binary (a b)
+ `(- ,a ,b))
+
+(define-macro (plus . args)
+ `(let ((res (+ ,@args)))
+ ;;(format #t "plus -> ~a~%" res)
+ res))
+
+\f
+(plus (let* ((x (minus-binary 12 7)) ;; 5
+ (y (minus-binary x 1))) ;; 4
+ (plus x y 5)) ;; 14
+ 12 ;; 26
+ (expt 2 3)) ;; => 34
+
--- /dev/null
+; Currently, map is a C function, so this is a way of testing that the
+; VM is reentrant.
+
+(begin
+
+ (define (square x)
+ (* x x))
+
+ (map (lambda (x) (square x))
+ '(1 2 3)))
--- /dev/null
+;;; Pattern matching with `(ice-9 match)'.
+;;;
+
+(use-modules (ice-9 match)
+ (srfi srfi-9)) ;; record type (FIXME: See `t-records.scm')
+
+(define-record-type <stuff>
+ (%make-stuff chbouib)
+ stuff?
+ (chbouib stuff:chbouib stuff:set-chbouib!))
+
+(define (matches? obj)
+; (format #t "matches? ~a~%" obj)
+ (match obj
+ (($ stuff) => #t)
+; (blurps #t)
+ ("hello" #t)
+ (else #f)))
+
+\f
+;(format #t "go!~%")
+(and (matches? (%make-stuff 12))
+ (matches? (%make-stuff 7))
+ (matches? "hello")
+; (matches? 'blurps)
+ (not (matches? 66)))
--- /dev/null
+(define (even? x)
+ (or (zero? x)
+ (not (odd? (1- x)))))
+
+(define (odd? x)
+ (not (even? (1- x))))
+
+(even? 20)
--- /dev/null
+;; all the different permutations of or
+(list
+ ;; not in tail position, no args
+ (or)
+ ;; not in tail position, one arg
+ (or 'what)
+ (or #f)
+ ;; not in tail position, two arg
+ (or 'what 'where)
+ (or #f 'where)
+ (or #f #f)
+ (or 'what #f)
+ ;; in tail position (within the lambdas)
+ ((lambda ()
+ (or)))
+ ((lambda ()
+ (or 'what)))
+ ((lambda ()
+ (or #f)))
+ ((lambda ()
+ (or 'what 'where)))
+ ((lambda ()
+ (or #f 'where)))
+ ((lambda ()
+ (or #f #f)))
+ ((lambda ()
+ (or 'what #f))))
--- /dev/null
+(define the-struct (vector 1 2))
+
+(define get/set
+ (make-procedure-with-setter
+ (lambda (struct name)
+ (case name
+ ((first) (vector-ref struct 0))
+ ((second) (vector-ref struct 1))
+ (else #f)))
+ (lambda (struct name val)
+ (case name
+ ((first) (vector-set! struct 0 val))
+ ((second) (vector-set! struct 1 val))
+ (else #f)))))
+
+(and (eq? (vector-ref the-struct 0) (get/set the-struct 'first))
+ (eq? (vector-ref the-struct 1) (get/set the-struct 'second))
+ (begin
+ (set! (get/set the-struct 'second) 77)
+ (eq? (vector-ref the-struct 1) (get/set the-struct 'second))))
--- /dev/null
+;;; SRFI-9 Records.
+;;;
+
+(use-modules (srfi srfi-9))
+
+(define-record-type <stuff>
+ (%make-stuff chbouib)
+ stuff?
+ (chbouib stuff:chbouib stuff:set-chbouib!))
+
+\f
+(and (stuff? (%make-stuff 12))
+ (= 7 (stuff:chbouib (%make-stuff 7)))
+ (not (stuff? 12))
+ (not (false-if-exception (%make-stuff))))
--- /dev/null
+(use-modules (ice-9 receive))
+
+(define (do-stuff x y)
+ (values x y))
+
+(call-with-values (lambda () (values 1 2))
+ (lambda (x y) (cons x y)))
+
--- /dev/null
+-*- Outline -*-
+
+Once (system vm assemble) is compiled, things start to fail in
+unpredictable ways.
+
+* `compile-file' of non-closure-using programs works
+
+$ guile-disasm t-records.go > t-records.ref.asm
+...
+$ diff -uBb t-macros.*.asm
+$ diff -uBb t-records.*.asm
+$ diff -uBb t-global-bindings.*.asm
+
+* `compile-file' of closure-using programs fails
+
+ERROR: During compiling t-closure.scm:
+ERROR: VM: Wrong type to apply: #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) [IP offset: 28]
+
+guile> (vm-debugger (the-vm))
+debug> bt
+#1 #<variable 30b12468 value: (#(<glil-asm> #(<glil-vars> ((nargs . 0) (nrest . 0) (nlocs . 0) (nexts . 1))) (#(<glil-const> 2) #(<glil-bind> ((x external 0))) #(<glil-external> set 0 0) #(<glil-asm> #(<glil-vars> ((nargs . 0) (nrest . 0) (nlocs . 1) (nexts . 0))) (#(<glil-module> ref #f +) #(<glil-const> 1) #(<glil-external> ref 1 0) #(<glil-call> call 2) #(<glil-source> (2 . 15)) #(<glil-bind> ((x++ local 0))) #(<glil-local> set 0) #(<glil-local> ref 0) #(<glil-external> set 1 0) #(<glil-local> ref 0) #(<glil-call> return 0) #(<glil-unbind>))) #(<glil-call> return 0) #(<glil-unbind>))) #<directory (guile-user) 100742d0> ())>
+#2 (#<program 30ae74b8> #(<glil-vars> ...) (#(<glil-const> ...) #(<glil-bind> ...) ...))
+#3 (#<program 30af7090>)
+#4 (#<program 30af94c0> #(<glil-vars> ...) (#(<glil-module> ...) #(<glil-const> ...) ...))
+#5 (#<program 30b00108>)
+#6 (#<program 30b02590> ref ...)
+#7 (_l 1 #(<venv> ...))
+guile> (vm-debugger (the-vm))
+debug> stack
+(#t closure? #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) #<procedure #f (struct name val)> #<primitive-generic map> #<primitive-generic map> #<program 30998470>)
+
+* Compiling anything "by hand" fails
+
+** Example 1: the read/compile/run loop
+
+guile> (set! %load-path (cons "/home/ludo/src/guile-vm/module" %load-path))
+guile> (use-modules (system vm assemble)(system vm core)(system repl repl))
+guile> (start-repl 'scheme)
+Guile Scheme interpreter 0.5 on Guile 1.7.2
+Copyright (C) 2001 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+scheme@guile-user> (use-modules (ice-9 match)
+ (system base syntax)
+ (system vm assemble))
+
+(define (%preprocess x e)
+ (match x
+ (($ <glil-asm> vars body)
+ (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
+ (body (map (lambda (x) (preprocess x venv)) body)))
+ (<vm-asm> :venv venv :glil x :body body)))
+ (($ <glil-external> op depth index)
+ (do ((d depth (1- d))
+ (e e (slot e 'parent)))
+ ((= d 0))
+ (set! (slot e 'closure?) #t))
+ x)
+ (else x)))
+
+scheme@guile-user> preprocess
+#<procedure preprocess (x e)>
+scheme@guile-user> (getpid)
+470
+scheme@guile-user> (set! preprocess %preprocess)
+scheme@guile-user> preprocess
+ERROR: VM: Unbound variable: #<variable 30a0d5e0 value: #<undefined>>
+scheme@guile-user> getpid
+ERROR: VM: Unbound variable: #<variable 30a0d5e0 value: #<undefined>>
+scheme@guile-user>
+
+
+** Example 2: the test suite (which also reads/compiles/runs)
+
+All the closure-using tests fail.
+
+ludo@lully:~/src/guile-vm/testsuite $ make check
+../src/guile-vm -L ../module \
+ -l run-vm-tests.scm -e run-vm-tests \
+ t-global-bindings.scm t-closure.scm t-closure2.scm t-closure3.scm t-do-loop.scm t-macros.scm t-proc-with-setter.scm t-values.scm t-records.scm t-match.scm
+
+running `t-global-bindings.scm'... reading... compiling... running... ok
+running `t-closure.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-closure2.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 0) (closure? . #f)))) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-closure3.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong ype to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 0) (closure? . #f)))) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-do-loop.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-macros.scm'... reading... compiling... running... ok
+running `t-proc-with-setter.scm'... reading... compiling... running... ok
+running `t-values.scm'... reading... compiling... running... ok
+running `t-records.scm'... reading... compiling... running... ok
+running `t-match.scm'... reading... compiling... running... ok
+
+4 tests failed out of 10
+make: *** [check] Error 4
+
HCoop / bpt / guile.git / commitdiff