diff options
146 files changed, 39618 insertions, 480 deletions
diff --git a/.gitignore b/.gitignore index a1221767f..3ba3b6f35 100644 --- a/.gitignore +++ b/.gitignore @@ -37,7 +37,7 @@ autom4te.cache benchmark-guile check-guile check-guile.log -compile +build-aux/compile confdefs.h config.build-subdirs config.cache @@ -68,5 +68,8 @@ guile-procedures.txt guile-config/guile-config guile-readline/guile-readline-config.h guile-readline/guile-readline-config.h.in +*.go TAGS guile-1.8.pc +lib/alloca.h +lib/strings.h diff --git a/Makefile.am b/Makefile.am index 5b6e9e67d..c6a694432 100644 --- a/Makefile.am +++ b/Makefile.am @@ -24,8 +24,9 @@ # 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 +SUBDIRS = lib oop libguile guile-config guile-readline emacs \ + scripts srfi doc examples test-suite benchmark-suite lang am \ + module ice-9 testsuite bin_SCRIPTS = guile-tools diff --git a/NEWS.guile-vm b/NEWS.guile-vm new file mode 100644 index 000000000..c82942f4f --- /dev/null +++ b/NEWS.guile-vm @@ -0,0 +1,57 @@ +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. diff --git a/README.guile-vm b/README.guile-vm new file mode 100644 index 000000000..72ab6c914 --- /dev/null +++ b/README.guile-vm @@ -0,0 +1,117 @@ +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 diff --git a/THANKS.guile-vm b/THANKS.guile-vm new file mode 100644 index 000000000..e3ea26ec5 --- /dev/null +++ b/THANKS.guile-vm @@ -0,0 +1 @@ +Guile VM was inspired by QScheme, librep, and Objective Caml. diff --git a/benchmark/lib.scm b/benchmark/lib.scm new file mode 100644 index 000000000..457fc41be --- /dev/null +++ b/benchmark/lib.scm @@ -0,0 +1,111 @@ +;; -*- 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))))) diff --git a/benchmark/measure.scm b/benchmark/measure.scm new file mode 100755 index 000000000..f100397cf --- /dev/null +++ b/benchmark/measure.scm @@ -0,0 +1,68 @@ +#!/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)) + + +(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) diff --git a/configure.in b/configure.in index e67e1d84a..6354e9e99 100644 --- a/configure.in +++ b/configure.in @@ -288,6 +288,8 @@ AC_CHECK_LIB(uca, __uc_get_ar_bsp) AC_C_BIGENDIAN +AC_C_LABELS_AS_VALUES + AC_CHECK_SIZEOF(char) AC_CHECK_SIZEOF(unsigned char) AC_CHECK_SIZEOF(short) @@ -1552,6 +1554,15 @@ AC_CONFIG_FILES([ srfi/Makefile test-suite/Makefile test-suite/standalone/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]) diff --git a/doc/Makefile.am b/doc/Makefile.am index 599af2ba9..331a46815 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -48,3 +48,4 @@ guile-api.alist: guile-api.alist-FORCE ( cd $(top_builddir) ; $(mscripts)/update-guile-api.alist ) guile-api.alist-FORCE: +info_TEXINFOS = guile-vm.texi diff --git a/doc/goops.mail b/doc/goops.mail new file mode 100644 index 000000000..305e80403 --- /dev/null +++ b/doc/goops.mail @@ -0,0 +1,78 @@ +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. ;-)] + diff --git a/doc/guile-vm.texi b/doc/guile-vm.texi new file mode 100644 index 000000000..927c09e88 --- /dev/null +++ b/doc/guile-vm.texi @@ -0,0 +1,1042 @@ +\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 + + +@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 + + + +@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 diff --git a/doc/texinfo.tex b/doc/texinfo.tex new file mode 100644 index 000000000..d2b264dd9 --- /dev/null +++ b/doc/texinfo.tex @@ -0,0 +1,8962 @@ +% 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 @@ -0,0 +1,5 @@ +#!/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 "$@" diff --git a/gdbinit b/gdbinit new file mode 100644 index 000000000..40c8f62bc --- /dev/null +++ b/gdbinit @@ -0,0 +1,188 @@ +define newline + call (void)scm_newline (scm_current_error_port ()) +end + +define gdisplay + call (void)scm_display ($arg0, scm_current_error_port ()) + newline +end + +define gwrite + call (void)scm_write ($arg0, scm_current_error_port ()) + newline +end + +define sputs + call (void)scm_puts ($arg0, scm_current_error_port ()) +end + +define gslot + print ((SCM**)$arg0)[1][$arg1] +end + +define pslot + gslot $arg0 $arg1 + gwrite $ +end + +define lforeach + set $l=$arg0 + while $l != 0x404 + set $x=scm_car($l) + $arg1 $x + set $l = scm_cdr($l) + end +end + +define modsum + modname $arg0 + gslot $arg0 1 + set $uses=$ + output "uses:\n" + lforeach $uses modname +end + +define moduses + pslot $arg0 1 +end + +define modname + pslot $arg0 5 +end + +define modkind + pslot $arg0 6 +end + +define car + call scm_car ($arg0) +end + +define cdr + call scm_cdr ($arg0) +end + +define smobwordtox + set $x=((SCM*)$arg0)[$arg1] +end + +define smobdatatox + smobwordtox $arg0 1 +end + +define program + smobdatatox $arg0 + p *(struct scm_program*)$x +end + +define proglocals + set $i=bp->nlocs + while $i > 0 + set $i=$i-1 + gwrite fp[bp->nargs+$i] + end +end + +define progstack + set $x=sp + while $x > stack_base + gwrite *$x + set $x=$x-1 + end +end + +define tc16 + p ((scm_t_bits)$arg0) & 0xffff +end + +define smobdescriptor + p scm_smobs[0xff & (((scm_t_bits)$arg0) >> 8)] +end + +define vmstack + set $vmsp=sp + set $vmstack_base=stack_base + set $vmfp=fp + set $vmbp=bp + set $vmframe=0 + while $vmsp > vp->stack_base + set $orig_vmsp=$vmsp + while $vmsp > $vmstack_base + output $orig_vmsp - $vmsp + sputs "\t" + output $vmsp + sputs "\t" + gwrite *$vmsp + set $vmsp=$vmsp-1 + end + newline + sputs "Frame " + output $vmframe + newline + sputs "ra:\t" + output $vmsp + sputs "\t" + output (SCM*)*$vmsp + set $vmsp=$vmsp-1 + newline + sputs "mvra:\t" + output $vmsp + sputs "\t" + output (SCM*)*$vmsp + set $vmsp=$vmsp-1 + newline + sputs "dl:\t" + output $vmsp + sputs "\t" + set $vmdl=(SCM*)(*$vmsp) + output $vmdl + newline + set $vmsp=$vmsp-1 + sputs "hl:\t" + output $vmsp + sputs "\t" + gwrite *$vmsp + set $vmsp=$vmsp-1 + sputs "el:\t" + output $vmsp + sputs "\t" + gwrite *$vmsp + set $vmsp=$vmsp-1 + set $vmnlocs=(int)$vmbp->nlocs + while $vmnlocs > 0 + sputs "loc #" + output $vmnlocs + sputs ":\t" + output $vmsp + sputs "\t" + gwrite *$vmsp + set $vmsp=$vmsp-1 + set $vmnlocs=$vmnlocs-1 + end + set $vmnargs=(int)$vmbp->nargs + while $vmnargs > 0 + sputs "arg #" + output $vmnargs + sputs ":\t" + output $vmsp + sputs "\t" + gwrite *$vmsp + set $vmsp=$vmsp-1 + set $vmnargs=$vmnargs-1 + end + sputs "prog:\t" + output $vmsp + sputs "\t" + gwrite *$vmsp + set $vmsp=$vmsp-1 + newline + if !$vmdl + loop_break + end + set $vmfp=$vmdl + set $vmbp=(struct scm_program*)(((SCM*)($vmfp[-1]))[1]) + set $vmstack_base=$vmfp+$vmbp->nargs+$vmbp->nlocs+4 + set $vmframe=$vmframe+1 + newline + end +end diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index e74bc0243..c35602f0c 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -215,7 +215,7 @@ (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)))))) diff --git a/guile-tools.in b/guile-tools.in index a4db08f02..a0255b53f 100644 --- a/guile-tools.in +++ b/guile-tools.in @@ -43,7 +43,7 @@ EOF } prefix="@prefix@" -pkgdatadir="@datadir@/@PACKAGE@" +pkgdatadir="@datarootdir@/@PACKAGE@" guileversion="@GUILE_EFFECTIVE_VERSION@" default_scriptsdir=$pkgdatadir/$guileversion/scripts diff --git a/guilec.mk b/guilec.mk new file mode 100644 index 000000000..01a1682c5 --- /dev/null +++ b/guilec.mk @@ -0,0 +1,11 @@ +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-env $(top_builddir)/guile-tools compile $< diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 22299c15f..e14548671 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -24,35 +24,52 @@ AUTOMAKE_OPTIONS = gnu 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 +# Compile psyntax and boot-9 first, so that we get the speed benefit in +# the rest of the compilation. Also, if there is too much switching back +# and forth between interpreted and compiled code, we end up using more +# of the C stack than the interpreter would have; so avoid that by +# putting these core modules first. +SOURCES = psyntax-pp.scm boot-9.scm \ + and-let-star.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 \ - match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \ - posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \ + networking.scm null.scm optargs.scm poe.scm popen.scm \ + posix.scm q.scm r4rs.scm r5rs.scm \ rdelim.scm receive.scm regex.scm runq.scm rw.scm \ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ streams.scm string-fun.scm syncase.scm threads.scm \ buffered-input.scm time.scm history.scm channel.scm \ - pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm \ + pretty-print.scm ftw.scm gap-buffer.scm \ weak-vector.scm deprecated.scm list.scm serialize.scm \ - gds-client.scm gds-server.scm + gds-server.scm -subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9 -subpkgdata_DATA = $(ice9_sources) -TAGS_FILES = $(subpkgdata_DATA) +# match.scm compiles, but then using it (via +# snarf-check-and-output-texi) fails. need to figure out what the +# problem is. +# +# occam-channel and gds-client use goops, which is not yet vm-compatible +# (it does some compilation-like optimizations for the interpreter), so +# punt on them for the time being. +# +# psyntax.scm needs help. fortunately it's only needed when recompiling +# psyntax-pp.scm. +NOCOMP_SOURCES = match.scm occam-channel.scm gds-client.scm psyntax.scm + +include $(top_srcdir)/guilec.mk ## test.scm is not currently installed. -EXTRA_DIST = $(ice9_sources) test.scm compile-psyntax.scm ChangeLog-2008 +EXTRA_DIST += test.scm compile-psyntax.scm ChangeLog-2008 + +TAGS_FILES = $(SOURCES) # We expect this to never be invoked when there is not already -# ice-9/psyntax.pp in %load-path, since compile-psyntax.scm depends -# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax.pp")'. +# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends +# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax-pp.scm")'. # In other words, to bootstrap this file, you need to do something like: -# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax.pp +# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm include $(top_srcdir)/am/pre-inst-guile -psyntax.pp: psyntax.ss +psyntax-pp.scm: psyntax.scm $(preinstguile) -s $(srcdir)/compile-psyntax.scm \ - $(srcdir)/psyntax.ss $(srcdir)/psyntax.pp - + $(srcdir)/psyntax.scm $(srcdir)/psyntax-pp.scm diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 6ada33c68..d3da2c645 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -92,9 +92,11 @@ ;; (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 @@ -123,6 +125,14 @@ +;; Before compiling, make sure any symbols are resolved in the (guile) +;; module, the primary location of those symbols, rather than in +;; (guile-user), the default module that we compile in. + +(eval-case + ((compile-toplevel) + (set-current-module (resolve-module '(guile))))) + ;;; {Defmacros} ;;; ;;; Depends on: features, eval-case @@ -151,18 +161,12 @@ (lambda (name parms . body) (let ((transformer `(lambda ,parms ,@body))) `(eval-case - ((load-toplevel) - (define ,name (defmacro:transformer ,transformer))) + ((load-toplevel compile-toplevel) + (define ,name (defmacro:transformer ,transformer))) (else (error "defmacro can only be used at the top level"))))))) (defmacro:transformer defmacro-transformer))) -(define defmacro:syntax-transformer - (lambda (f) - (procedure->syntax - (lambda (exp env) - (copy-tree (apply f (cdr exp))))))) - ;; XXX - should the definition of the car really be looked up in the ;; current module? @@ -196,15 +200,15 @@ (defmacro begin-deprecated forms (if (include-deprecated-features) - (cons begin forms) - #f)) + `(begin ,@forms) + (begin))) ;;; {R4RS compliance} ;;; -(primitive-load-path "ice-9/r4rs.scm") +(primitive-load-path "ice-9/r4rs") @@ -327,22 +331,6 @@ -;;; {Environments} -;;; - -(define the-environment - (procedure->syntax - (lambda (x e) - e))) - -(define the-root-environment (the-environment)) - -(define (environment-module env) - (let ((closure (and (pair? env) (car (last-pair env))))) - (and closure (procedure-property closure 'module)))) - - - ;;; {Records} ;;; @@ -418,14 +406,14 @@ (define (record-constructor rtd . opt) (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd)))) - (local-eval `(lambda ,field-names - (make-struct ',rtd 0 ,@(map (lambda (f) - (if (memq f field-names) - f - #f)) - (record-type-fields rtd)))) - the-root-environment))) - + (primitive-eval + `(lambda ,field-names + (make-struct ',rtd 0 ,@(map (lambda (f) + (if (memq f field-names) + f + #f)) + (record-type-fields rtd))))))) + (define (record-predicate rtd) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) @@ -437,25 +425,22 @@ #f))) (define (record-accessor rtd field-name) - (let* ((pos (list-index (record-type-fields rtd) field-name))) + (let ((pos (list-index (record-type-fields rtd) field-name))) (if (not pos) (error 'no-such-field field-name)) - (local-eval `(lambda (obj) - (if (eq? (struct-vtable obj) ,rtd) - (struct-ref obj ,pos) - (%record-type-error ,rtd obj))) - the-root-environment))) + (lambda (obj) + (if (eq? (struct-vtable obj) rtd) + (struct-ref obj pos) + (%record-type-error rtd obj))))) (define (record-modifier rtd field-name) - (let* ((pos (list-index (record-type-fields rtd) field-name))) + (let ((pos (list-index (record-type-fields rtd) field-name))) (if (not pos) (error 'no-such-field field-name)) - (local-eval `(lambda (obj val) - (if (eq? (struct-vtable obj) ,rtd) - (struct-set! obj ,pos val) - (%record-type-error ,rtd obj))) - the-root-environment))) - + (lambda (obj val) + (if (eq? (struct-vtable obj) rtd) + (struct-set! obj pos val) + (%record-type-error rtd obj))))) (define (record? obj) (and (struct? obj) (record-type? (struct-vtable obj)))) @@ -538,10 +523,10 @@ (if (provided? 'posix) - (primitive-load-path "ice-9/posix.scm")) + (primitive-load-path "ice-9/posix")) (if (provided? 'socket) - (primitive-load-path "ice-9/networking.scm")) + (primitive-load-path "ice-9/networking")) ;; For reference, Emacs file-exists-p uses stat in this same way. ;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in @@ -569,10 +554,7 @@ #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) @@ -768,6 +750,14 @@ +;;; {The interpreter stack} +;;; + +(defmacro start-stack (tag exp) + `(%start-stack ,tag (lambda () ,exp))) + + + ;;; {Loading by paths} ;;; @@ -1793,8 +1783,7 @@ ;;; The directory of all modules and the standard root module. ;;; -(define (module-public-interface m) - (module-ref m '%module-public-interface #f)) +;; module-public-interface is defined in C. (define (set-module-public-interface! m i) (module-define! m '%module-public-interface i)) (define (set-system-module! m s) @@ -1838,25 +1827,29 @@ ;; NOTE: This binding is used in libguile/modules.c. ;; -(define (resolve-module name . maybe-autoload) - (let ((full-name (append '(%app modules) name))) - (let ((already (nested-ref the-root-module full-name))) - (if already - ;; The module already exists... - (if (and (or (null? maybe-autoload) (car maybe-autoload)) - (not (module-public-interface already))) - ;; ...but we are told to load and it doesn't contain source, so - (begin - (try-load-module name) - already) - ;; simply return it. - already) - (begin - ;; Try to autoload it if we are told so - (if (or (null? maybe-autoload) (car maybe-autoload)) - (try-load-module name)) - ;; Get/create it. - (make-modules-in (current-module) full-name)))))) +(define resolve-module + (let ((the-root-module the-root-module)) + (lambda (name . maybe-autoload) + (if (equal? name '(guile)) + the-root-module + (let ((full-name (append '(%app modules) name))) + (let ((already (nested-ref the-root-module full-name))) + (if already + ;; The module already exists... + (if (and (or (null? maybe-autoload) (car maybe-autoload)) + (not (module-public-interface already))) + ;; ...but we are told to load and it doesn't contain source, so + (begin + (try-load-module name) + already) + ;; simply return it. + already) + (begin + ;; Try to autoload it if we are told so + (if (or (null? maybe-autoload) (car maybe-autoload)) + (try-load-module name)) + ;; Get/create it. + (make-modules-in (current-module) full-name))))))))) ;; Cheat. These bindings are needed by modules.c, but we don't want ;; to move their real definition here because that would be unnatural. @@ -1867,16 +1860,17 @@ (define module-export! #f) (define default-duplicate-binding-procedures #f) -;; This boots the module system. All bindings needed by modules.c -;; must have been defined by now. -;; -(set-current-module the-root-module) - (define %app (make-module 31)) (define app %app) ;; for backwards compatability + (local-define '(%app modules) (make-module 31)) (local-define '(%app modules guile) the-root-module) +;; This boots the module system. All bindings needed by modules.c +;; must have been defined by now. +;; +(set-current-module the-root-module) + ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) (define (try-load-module name) @@ -1997,98 +1991,98 @@ (error "unrecognized define-module argument" arg)))) (beautify-user-module! module) (let loop ((kws kws) - (reversed-interfaces '()) - (exports '()) - (re-exports '()) - (replacements '()) + (reversed-interfaces '()) + (exports '()) + (re-exports '()) + (replacements '()) (autoloads '())) (if (null? kws) - (call-with-deferred-observers - (lambda () - (module-use-interfaces! module (reverse reversed-interfaces)) - (module-export! module exports) - (module-replace! module replacements) - (module-re-export! module re-exports) + (call-with-deferred-observers + (lambda () + (module-use-interfaces! module (reverse reversed-interfaces)) + (module-export! module exports) + (module-replace! module replacements) + (module-re-export! module re-exports) (if (not (null? autoloads)) (apply module-autoload! module autoloads)))) - (case (car kws) - ((#:use-module #:use-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (let* ((interface-args (cadr kws)) - (interface (apply resolve-interface interface-args))) - (and (eq? (car kws) #:use-syntax) - (or (symbol? (caar interface-args)) - (error "invalid module name for use-syntax" - (car interface-args))) - (set-module-transformer! - module - (module-ref interface - (car (last-pair (car interface-args))) - #f))) - (loop (cddr kws) - (cons interface reversed-interfaces) - exports - re-exports - replacements + (case (car kws) + ((#:use-module #:use-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (let* ((interface-args (cadr kws)) + (interface (apply resolve-interface interface-args))) + (and (eq? (car kws) #:use-syntax) + (or (symbol? (caar interface-args)) + (error "invalid module name for use-syntax" + (car interface-args))) + (set-module-transformer! + module + (module-ref interface + (car (last-pair (car interface-args))) + #f))) + (loop (cddr kws) + (cons interface reversed-interfaces) + exports + re-exports + replacements autoloads))) - ((#:autoload) - (or (and (pair? (cdr kws)) (pair? (cddr kws))) - (unrecognized kws)) - (loop (cdddr kws) + ((#:autoload) + (or (and (pair? (cdr kws)) (pair? (cddr kws))) + (unrecognized kws)) + (loop (cdddr kws) reversed-interfaces - exports - re-exports - replacements + exports + re-exports + replacements (let ((name (cadr kws)) (bindings (caddr kws))) (cons* name bindings autoloads)))) - ((#:no-backtrace) - (set-system-module! module #t) - (loop (cdr kws) reversed-interfaces exports re-exports + ((#:no-backtrace) + (set-system-module! module #t) + (loop (cdr kws) reversed-interfaces exports re-exports replacements autoloads)) - ((#:pure) - (purify-module! module) - (loop (cdr kws) reversed-interfaces exports re-exports + ((#:pure) + (purify-module! module) + (loop (cdr kws) reversed-interfaces exports re-exports replacements autoloads)) - ((#:duplicates) - (if (not (pair? (cdr kws))) - (unrecognized kws)) - (set-module-duplicates-handlers! - module - (lookup-duplicates-handlers (cadr kws))) - (loop (cddr kws) reversed-interfaces exports re-exports + ((#:duplicates) + (if (not (pair? (cdr kws))) + (unrecognized kws)) + (set-module-duplicates-handlers! + module + (lookup-duplicates-handlers (cadr kws))) + (loop (cddr kws) reversed-interfaces exports re-exports replacements autoloads)) - ((#:export #:export-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (loop (cddr kws) - reversed-interfaces - (append (cadr kws) exports) - re-exports - replacements + ((#:export #:export-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (loop (cddr kws) + reversed-interfaces + (append (cadr kws) exports) + re-exports + replacements autoloads)) - ((#:re-export #:re-export-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (loop (cddr kws) - reversed-interfaces - exports - (append (cadr kws) re-exports) - replacements + ((#:re-export #:re-export-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (loop (cddr kws) + reversed-interfaces + exports + (append (cadr kws) re-exports) + replacements autoloads)) - ((#:replace #:replace-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (loop (cddr kws) - reversed-interfaces - exports - re-exports - (append (cadr kws) replacements) + ((#:replace #:replace-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (loop (cddr kws) + reversed-interfaces + exports + re-exports + (append (cadr kws) replacements) autoloads)) - (else - (unrecognized kws))))) + (else + (unrecognized kws))))) (run-hook module-defined-hook module) module)) @@ -2137,7 +2131,8 @@ module '(ice-9 q) '(make-q q-length))}." ;;; {Compiled module} -(define load-compiled #f) +(if (not (defined? 'load-compiled)) + (define load-compiled #f)) @@ -2167,14 +2162,20 @@ module '(ice-9 q) '(make-q q-length))}." (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)))) @@ -2215,23 +2216,11 @@ module '(ice-9 q) '(make-q q-length))}." ;;; {Run-time options} ;;; -(define define-option-interface +(defmacro define-option-interface (option-group) (let* ((option-name car) (option-value cadr) (option-documentation caddr) - (print-option (lambda (option) - (display (option-name option)) - (if (< (string-length - (symbol->string (option-name option))) - 8) - (display #\tab)) - (display #\tab) - (display (option-value option)) - (display #\tab) - (display (option-documentation option)) - (newline))) - ;; Below follow the macros defining the run-time option interfaces. (make-options (lambda (interface) @@ -2239,8 +2228,19 @@ module '(ice-9 q) '(make-q q-length))}." (cond ((null? args) (,interface)) ((list? (car args)) (,interface (car args)) (,interface)) - (else (for-each ,print-option - (,interface #t))))))) + (else (for-each + (lambda (option) + (display (option-name option)) + (if (< (string-length + (symbol->string (option-name option))) + 8) + (display #\tab)) + (display #\tab) + (display (option-value option)) + (display #\tab) + (display (option-documentation option)) + (newline)) + (,interface #t))))))) (make-enable (lambda (interface) `(lambda flags @@ -2255,22 +2255,19 @@ module '(ice-9 q) '(make-q q-length))}." flags) (,interface options) (,interface)))))) - (procedure->memoizing-macro - (lambda (exp env) - (let* ((option-group (cadr exp)) - (interface (car option-group)) - (options/enable/disable (cadr option-group))) - `(begin - (define ,(car options/enable/disable) - ,(make-options interface)) - (define ,(cadr options/enable/disable) - ,(make-enable interface)) - (define ,(caddr options/enable/disable) - ,(make-disable interface)) - (defmacro ,(caaddr option-group) (opt val) - `(,,(car options/enable/disable) - (append (,,(car options/enable/disable)) - (list ',opt ,val)))))))))) + (let* ((interface (car option-group)) + (options/enable/disable (cadr option-group))) + `(begin + (define ,(car options/enable/disable) + ,(make-options interface)) + (define ,(cadr options/enable/disable) + ,(make-enable interface)) + (define ,(caddr options/enable/disable) + ,(make-disable interface)) + (defmacro ,(caaddr option-group) (opt val) + `(,',(car options/enable/disable) + (append (,',(car options/enable/disable)) + (list ',opt ,val)))))))) (define-option-interface (eval-options-interface @@ -2526,7 +2523,7 @@ module '(ice-9 q) '(make-q q-length))}." ;;; 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)))) @@ -2710,24 +2707,12 @@ module '(ice-9 q) '(make-q q-length))}." (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"))))) -(defmacro define-syntax-macro (first . rest) - (let ((name (if (symbol? first) first (car first))) - (transformer - (if (symbol? first) - (car rest) - `(lambda ,(cdr first) ,@rest)))) - `(eval-case - ((load-toplevel) - (define ,name (defmacro:syntax-transformer ,transformer))) - (else - (error "define-syntax-macro can only be used at the top level"))))) - ;;; {While} @@ -2752,18 +2737,18 @@ module '(ice-9 q) '(make-q q-length))}." ;; This is probably a bug in syncase. ;; (define-macro (while cond . body) - (define (while-helper proc) - (do ((key (make-symbol "while-key"))) - ((catch key - (lambda () - (proc (lambda () (throw key #t)) - (lambda () (throw key #f)))) - (lambda (key arg) arg))))) - `(,while-helper (,lambda (break continue) - (do () - ((,not ,cond)) - ,@body) - #t))) + (let ((key (make-symbol "while-key"))) + `(do () + ((catch ',key + (lambda () + (let ((break (lambda () (throw ',key #t))) + (continue (lambda () (throw ',key #f)))) + (do () + ((not ,cond)) + ,@body) + #t)) + (lambda (key arg) + arg)))))) @@ -2774,6 +2759,11 @@ module '(ice-9 q) '(make-q q-length))}." ;; Return a list of expressions that evaluate to the appropriate ;; arguments for resolve-interface according to SPEC. +(eval-case + ((compile-toplevel) + (if (memq 'prefix (read-options)) + (error "boot-9 must be compiled with #:kw, not :kw")))) + (define (compile-interface-spec spec) (define (make-keyarg sym key quote?) (cond ((or (memq sym spec) @@ -2838,7 +2828,7 @@ module '(ice-9 q) '(make-q q-length))}." (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) @@ -2863,7 +2853,7 @@ module '(ice-9 q) '(make-q q-length))}." (defmacro use-modules modules `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) (process-use-modules (list ,@(map (lambda (m) `(list ,@(compile-interface-spec m))) @@ -2874,7 +2864,7 @@ module '(ice-9 q) '(make-q q-length))}." (defmacro use-syntax (spec) `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) ,@(if (pair? spec) `((process-use-modules (list (list ,@(compile-interface-spec spec)))) @@ -2904,7 +2894,7 @@ module '(ice-9 q) '(make-q q-length))}." (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) @@ -2919,7 +2909,7 @@ module '(ice-9 q) '(make-q q-length))}." (#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 @@ -2958,7 +2948,7 @@ module '(ice-9 q) '(make-q q-length))}." (defmacro export names `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) (call-with-deferred-observers (lambda () (module-export! (current-module) ',names)))) @@ -2967,7 +2957,7 @@ module '(ice-9 q) '(make-q q-length))}." (defmacro re-export names `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) (call-with-deferred-observers (lambda () (module-re-export! (current-module) ',names)))) @@ -2992,6 +2982,7 @@ module '(ice-9 q) '(make-q q-length))}." ;; Indeed, all references to global variables are memoized into such ;; variable objects. +;; FIXME: these don't work with the compiler (define-macro (@ mod-name var-name) (let ((var (module-variable (resolve-interface mod-name) var-name))) (if (not var) @@ -3354,6 +3345,8 @@ module '(ice-9 q) '(make-q q-length))}." ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have ;; no effect. (let ((old-handlers #f) + (start-repl (module-ref (resolve-interface '(system repl repl)) + 'start-repl)) (signals (if (provided? 'posix) `((,SIGINT . "User interrupt") (,SIGFPE . "Arithmetic error") @@ -3388,7 +3381,7 @@ module '(ice-9 q) '(make-q q-length))}." ;; the protected thunk. (lambda () - (let ((status (scm-style-repl))) + (let ((status (start-repl 'scheme))) (run-hook exit-hook) status)) @@ -3420,7 +3413,7 @@ module '(ice-9 q) '(make-q q-length))}." (provided? sym))) (begin-deprecated - (primitive-load-path "ice-9/deprecated.scm")) + (primitive-load-path "ice-9/deprecated")) diff --git a/ice-9/documentation.scm b/ice-9/documentation.scm index 6e74799e6..c5f447e78 100644 --- a/ice-9/documentation.scm +++ b/ice-9/documentation.scm @@ -80,6 +80,7 @@ (define-module (ice-9 documentation) :use-module (ice-9 rdelim) + :use-module ((system vm program) :select (program? program-documentation)) :export (file-commentary documentation-files search-documentation-files object-documentation) @@ -201,6 +202,8 @@ OBJECT can be a procedure, macro or any object that has its (and transformer (proc-doc transformer)))) (object-property object 'documentation) + (and (program? object) + (program-documentation object)) (and (procedure? object) (not (closure? object)) (procedure-name object) diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm index 99329c750..4dea92fd7 100644 --- a/ice-9/optargs.scm +++ b/ice-9/optargs.scm @@ -149,11 +149,10 @@ => cdr) (else ,(cadr key))))))) - `(let* ((ra->kbl ,rest-arg->keyword-binding-list) - (,kb-list-gensym (ra->kbl ,REST-ARG ',(map - (lambda (x) (symbol->keyword (if (pair? x) (car x) x))) - BINDINGS) - ,ALLOW-OTHER-KEYS?))) + `(let ((,kb-list-gensym ((@@ (ice-9 optargs) rest-arg->keyword-binding-list) + ,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x))) + BINDINGS) + ,ALLOW-OTHER-KEYS?))) ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter))))) diff --git a/ice-9/psyntax.pp b/ice-9/psyntax-pp.scm index 4abf7bcc9..4abf7bcc9 100644 --- a/ice-9/psyntax.pp +++ b/ice-9/psyntax-pp.scm diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.scm index 22e409d3e..22e409d3e 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.scm diff --git a/ice-9/runq.scm b/ice-9/runq.scm index 6ac4e5783..eb1e2203f 100644 --- a/ice-9/runq.scm +++ b/ice-9/runq.scm @@ -216,13 +216,14 @@ ;;; ;;; Returns a new strip which is the concatenation of the argument strips. ;;; -(define ((strip-sequence . strips)) - (let loop ((st (let ((a strips)) (set! strips #f) a))) - (and (not (null? st)) - (let ((then ((car st)))) - (if then - (lambda () (loop (cons then (cdr st)))) - (lambda () (loop (cdr st)))))))) +(define (strip-sequence . strips) + (lambda () + (let loop ((st (let ((a strips)) (set! strips #f) a))) + (and (not (null? st)) + (let ((then ((car st)))) + (if then + (lambda () (loop (cons then (cdr st)))) + (lambda () (loop (cdr st))))))))) ;;;; diff --git a/ice-9/session.scm b/ice-9/session.scm index 1c9f48016..25cd6e8dc 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -22,73 +22,71 @@ :use-module (ice-9 rdelim) :export (help apropos apropos-internal apropos-fold apropos-fold-accessible apropos-fold-exported apropos-fold-all - source arity system-module)) + source arity)) ;;; Documentation ;;; -(define help - (procedure->syntax - (lambda (exp env) - "(help [NAME]) +(define-macro (help . exp) + "(help [NAME]) Prints useful information. Try `(help)'." - (cond ((not (= (length exp) 2)) - (help-usage)) - ((not (provided? 'regex)) - (display "`help' depends on the `regex' feature. + (cond ((not (= (length exp) 1)) + (help-usage)) + ((not (provided? 'regex)) + (display "`help' depends on the `regex' feature. You don't seem to have regular expressions installed.\n")) + (else + (let ((name (car exp)) + (not-found (lambda (type x) + (simple-format #t "No ~A found for ~A\n" + type x)))) + (cond + + ;; SYMBOL + ((symbol? name) + (help-doc name + (simple-format + #f "^~A$" + (regexp-quote (symbol->string name))))) + + ;; "STRING" + ((string? name) + (help-doc name name)) + + ;; (unquote SYMBOL) + ((and (list? name) + (= (length name) 2) + (eq? (car name) 'unquote)) + (cond ((object-documentation + (eval (cadr name) (current-module))) + => write-line) + (else (not-found 'documentation (cadr name))))) + + ;; (quote SYMBOL) + ((and (list? name) + (= (length name) 2) + (eq? (car name) 'quote) + (symbol? (cadr name))) + (cond ((search-documentation-files (cadr name)) + => write-line) + (else (not-found 'documentation (cadr name))))) + + ;; (SYM1 SYM2 ...) + ((and (list? name) + (and-map symbol? name) + (not (null? name)) + (not (eq? (car name) 'quote))) + (cond ((module-commentary name) + => (lambda (doc) + (display name) (write-line " commentary:") + (write-line doc))) + (else (not-found 'commentary name)))) + + ;; unrecognized (else - (let ((name (cadr exp)) - (not-found (lambda (type x) - (simple-format #t "No ~A found for ~A\n" - type x)))) - (cond - - ;; SYMBOL - ((symbol? name) - (help-doc name - (simple-format - #f "^~A$" - (regexp-quote (symbol->string name))))) - - ;; "STRING" - ((string? name) - (help-doc name name)) - - ;; (unquote SYMBOL) - ((and (list? name) - (= (length name) 2) - (eq? (car name) 'unquote)) - (cond ((object-documentation - (local-eval (cadr name) env)) - => write-line) - (else (not-found 'documentation (cadr name))))) - - ;; (quote SYMBOL) - ((and (list? name) - (= (length name) 2) - (eq? (car name) 'quote) - (symbol? (cadr name))) - (cond ((search-documentation-files (cadr name)) - => write-line) - (else (not-found 'documentation (cadr name))))) - - ;; (SYM1 SYM2 ...) - ((and (list? name) - (and-map symbol? name) - (not (null? name)) - (not (eq? (car name) 'quote))) - (cond ((module-commentary name) - => (lambda (doc) - (display name) (write-line " commentary:") - (write-line doc))) - (else (not-found 'commentary name)))) - - ;; unrecognized - (else - (help-usage))) - *unspecified*)))))) + (help-usage))) + '(begin))))) (define (module-filename name) ; fixme: better way? / done elsewhere? (let* ((name (map symbol->string name)) @@ -458,17 +456,4 @@ It is an image under the mapping EXTRACT." (display #\')))))))) (display ".\n")) -(define system-module - (procedure->syntax - (lambda (exp env) - (let* ((m (nested-ref the-root-module - (append '(app modules) (cadr exp))))) - (if (not m) - (error "Couldn't find any module named" (cadr exp))) - (let ((s (not (procedure-property (module-eval-closure m) - 'system-module)))) - (set-system-module! m s) - (string-append "Module " (symbol->string (module-name m)) - " is now a " (if s "system" "user") " module.")))))) - ;;; session.scm ends here diff --git a/ice-9/string-fun.scm b/ice-9/string-fun.scm index 590a7d2a4..d8ba21f75 100644 --- a/ice-9/string-fun.scm +++ b/ice-9/string-fun.scm @@ -197,9 +197,10 @@ ;;; (define-public string-prefix=? (string-prefix-predicate string=?)) ;;; -(define ((string-prefix-predicate pred?) prefix str) - (and (<= (string-length prefix) (string-length str)) - (pred? prefix (substring str 0 (string-length prefix))))) +(define (string-prefix-predicate pred?) + (lambda (prefix str) + (and (<= (string-length prefix) (string-length str)) + (pred? prefix (substring str 0 (string-length prefix)))))) (define string-prefix=? (string-prefix-predicate string=?)) diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index 6ee4d166e..5fd3a3214 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -35,11 +35,12 @@ (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 @@ -107,7 +108,7 @@ (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 @@ -122,7 +123,7 @@ (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) @@ -137,7 +138,7 @@ (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 @@ -204,7 +205,7 @@ (lambda () (debug-disable 'debug 'procnames) (read-disable 'positions) - (load-from-path "ice-9/psyntax.pp")) + (load-from-path "ice-9/psyntax-pp")) (lambda () (debug-options old-debug) (read-options old-read)))) @@ -212,7 +213,7 @@ ;;; The following lines are necessary only if we start making changes ;; (use-syntax sc-expand) -;; (load-from-path "ice-9/psyntax.ss") +;; (load-from-path "ice-9/psyntax") (define internal-eval (nested-ref the-scm-module '(%app modules guile eval))) @@ -244,4 +245,4 @@ ;(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) diff --git a/ice-9/threads.scm b/ice-9/threads.scm index cdabb2417..bd0f7b745 100644 --- a/ice-9/threads.scm +++ b/ice-9/threads.scm @@ -47,12 +47,13 @@ -(define ((par-mapper mapper) proc . arglists) - (mapper join-thread - (apply map - (lambda args - (begin-thread (apply proc args))) - arglists))) +(define (par-mapper mapper) + (lambda (proc . arglists) + (mapper join-thread + (apply map + (lambda args + (begin-thread (apply proc args))) + arglists)))) (define par-map (par-mapper map)) (define par-for-each (par-mapper for-each)) diff --git a/libguile/.gitignore b/libguile/.gitignore index 41f7909d2..09f1b06b7 100644 --- a/libguile/.gitignore +++ b/libguile/.gitignore @@ -13,3 +13,4 @@ guile_filter_doc_snarfage libpath.h scmconfig.h version.h +vm-i-*.i diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 39b4016d0..cb8c94454 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -85,7 +85,7 @@ c-tokenize.$(OBJEXT): c-tokenize.c 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. @@ -122,6 +122,9 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ 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) @@ -146,6 +149,9 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ 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 \ @@ -169,9 +175,14 @@ 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 \ @@ -199,6 +210,9 @@ noinst_HEADERS = convert.i.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 @@ -226,6 +240,9 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ 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 diff --git a/libguile/continuations.c b/libguile/continuations.c index 74bb9112f..2b10126cf 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -35,6 +35,7 @@ #include "libguile/dynwind.h" #include "libguile/values.h" #include "libguile/eval.h" +#include "libguile/vm.h" #include "libguile/validate.h" #include "libguile/continuations.h" @@ -53,6 +54,7 @@ continuation_mark (SCM obj) scm_gc_mark (continuation->root); scm_gc_mark (continuation->throw_value); + scm_gc_mark (continuation->vm_conts); scm_mark_locations (continuation->stack, continuation->num_stack_items); #ifdef __ia64__ if (continuation->backing_store) @@ -126,6 +128,7 @@ scm_make_continuation (int *first) #endif continuation->offset = continuation->stack - src; memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); + continuation->vm_conts = scm_vm_capture_continuations (); *first = !setjmp (continuation->jmpbuf); if (*first) @@ -204,6 +207,7 @@ copy_stack (void *data) copy_stack_data *d = (copy_stack_data *)data; memcpy (d->dst, d->continuation->stack, sizeof (SCM_STACKITEM) * d->continuation->num_stack_items); + scm_vm_reinstate_continuations (d->continuation->vm_conts); #ifdef __ia64__ SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation; #endif diff --git a/libguile/continuations.h b/libguile/continuations.h index 1a648dd28..e5fd91f2e 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -51,6 +51,7 @@ typedef struct #endif /* __ia64__ */ size_t num_stack_items; /* size of the saved stack. */ SCM root; /* continuation root identifier. */ + SCM vm_conts; /* vm continuations (they use separate stacks) */ /* The offset from the live stack location to this copy. This is used to adjust pointers from within the copied stack to the stack diff --git a/libguile/debug.c b/libguile/debug.c index 7b91cd360..4de7024ab 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -72,7 +72,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, SCM_OUT_OF_RANGE (1, setting); } SCM_RESET_DEBUG_MODE; +#ifdef STACK_CHECKING scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; +#endif scm_debug_eframe_size = 2 * SCM_N_FRAMES; scm_dynwind_end (); @@ -446,8 +448,10 @@ scm_reverse_lookup (SCM env, SCM data) return SCM_BOOL_F; } -SCM -scm_start_stack (SCM id, SCM exp, SCM env) +SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0, + (SCM id, SCM thunk), + "Call @var{thunk} on an evaluator stack tagged with @var{id}.") +#define FUNC_NAME s_scm_sys_start_stack { SCM answer; scm_t_debug_frame vframe; @@ -457,27 +461,12 @@ scm_start_stack (SCM id, SCM exp, SCM env) vframe.vect = &vframe_vect_body; vframe.vect[0].id = id; scm_i_set_last_debug_frame (&vframe); - answer = scm_i_eval (exp, env); + answer = scm_call_0 (thunk); scm_i_set_last_debug_frame (vframe.prev); return answer; } - -SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack); - -static SCM -scm_m_start_stack (SCM exp, SCM env) -#define FUNC_NAME s_start_stack -{ - exp = SCM_CDR (exp); - if (!scm_is_pair (exp) - || !scm_is_pair (SCM_CDR (exp)) - || !scm_is_null (SCM_CDDR (exp))) - SCM_WRONG_NUM_ARGS (); - return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env); -} #undef FUNC_NAME - /* {Debug Objects} * * The debugging evaluator throws these on frame traps. diff --git a/libguile/debug.h b/libguile/debug.h index 607716230..4e94b3c15 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -138,7 +138,7 @@ SCM_API scm_t_bits scm_tc16_memoized; SCM_API SCM scm_debug_object_p (SCM obj); SCM_API SCM scm_local_eval (SCM exp, SCM env); SCM_API SCM scm_reverse_lookup (SCM env, SCM data); -SCM_API SCM scm_start_stack (SCM info_id, SCM exp, SCM env); +SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk); SCM_API SCM scm_procedure_environment (SCM proc); SCM_API SCM scm_procedure_source (SCM proc); SCM_API SCM scm_procedure_name (SCM proc); diff --git a/libguile/eval.c b/libguile/eval.c index 14dc3c377..26dff8274 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3662,13 +3662,23 @@ scm_closure (SCM code, SCM env) scm_t_bits scm_tc16_promise; -SCM -scm_makprom (SCM code) -{ +SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0, + (SCM thunk), + "Create a new promise object.\n\n" + "@code{make-promise} is a procedural form of @code{delay}.\n" + "These two expressions are equivalent:\n" + "@lisp\n" + "(delay @var{exp})\n" + "(make-promise (lambda () @var{exp}))\n" + "@end lisp\n") +#define FUNC_NAME s_scm_make_promise +{ + SCM_VALIDATE_THUNK (1, thunk); SCM_RETURN_NEWSMOB2 (scm_tc16_promise, - SCM_UNPACK (code), + SCM_UNPACK (thunk), scm_make_recursive_mutex ()); } +#undef FUNC_NAME static SCM promise_mark (SCM promise) diff --git a/libguile/eval.h b/libguile/eval.h index bf6279b82..333265263 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -162,7 +162,7 @@ SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_closure (SCM code, SCM env); -SCM_API SCM scm_makprom (SCM code); +SCM_API SCM scm_make_promise (SCM thunk); SCM_API SCM scm_force (SCM x); SCM_API SCM scm_promise_p (SCM x); SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y); diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 83878ff41..3d686700b 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -732,7 +732,7 @@ dispatch: case (ISYMNUM (SCM_IM_DELAY)): - RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); + RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env))); #if 0 /* See futures.h for a comment why futures are not enabled. diff --git a/libguile/frames.c b/libguile/frames.c new file mode 100644 index 000000000..36f057f7e --- /dev/null +++ b/libguile/frames.c @@ -0,0 +1,209 @@ +/* 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" + + +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_mv_return_address, "frame-mv-return-address", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_mv_return_address +{ + SCM_VALIDATE_HEAP_FRAME (1, frame); + return scm_from_ulong ((unsigned long) + (SCM_FRAME_MV_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 + + +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: +*/ diff --git a/libguile/frames.h b/libguile/frames.h new file mode 100644 index 000000000..f5323f712 --- /dev/null +++ b/libguile/frames.h @@ -0,0 +1,129 @@ +/* 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" + + +/* + * VM frames + */ + +/* VM Frame Layout + --------------- + + | | <- fp + bp->nargs + bp->nlocs + 4 + +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp) + | Return address | + | MV 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) + 5) +#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)[4])) +#define SCM_FRAME_MV_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] + + +/* + * 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_mv_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: +*/ diff --git a/libguile/gc-freelist.c b/libguile/gc-freelist.c index 7458bd4a5..4dd77aa0d 100644 --- a/libguile/gc-freelist.c +++ b/libguile/gc-freelist.c @@ -182,9 +182,11 @@ scm_i_gc_heap_size_delta (scm_t_cell_type_statistics * freelist) float swept = freelist->swept; float delta = ((f * swept - collected) / (1.0 - f)); +#if 0 assert (freelist->heap_total_cells >= freelist->collected); assert (freelist->swept == freelist->heap_total_cells); assert (swept >= collected); +#endif return delta; } diff --git a/libguile/init.c b/libguile/init.c index 522bec901..ac81be601 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -118,6 +118,7 @@ #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" @@ -281,7 +282,7 @@ scm_load_startup_files () /* Load Ice-9. */ if (!scm_ice_9_already_loaded) { - scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9.scm")); + scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9")); /* Load the init.scm file. */ if (scm_is_true (init_path)) @@ -572,6 +573,8 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_rw (); scm_init_extensions (); + scm_bootstrap_vm (); + atexit (cleanup_for_exit); scm_load_startup_files (); } diff --git a/libguile/instructions.c b/libguile/instructions.c new file mode 100644 index 000000000..89b6c774b --- /dev/null +++ b/libguile/instructions.c @@ -0,0 +1,181 @@ +/* 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: +*/ diff --git a/libguile/instructions.h b/libguile/instructions.h new file mode 100644 index 000000000..1a965daf9 --- /dev/null +++ b/libguile/instructions.h @@ -0,0 +1,99 @@ +/* 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: +*/ diff --git a/libguile/load.c b/libguile/load.c index 5ca4e07f4..1b5b24f35 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -44,6 +44,8 @@ #include "libguile/load.h" #include "libguile/fluids.h" +#include "libguile/vm.h" /* for load-compiled/vm */ + #include <sys/types.h> #include <sys/stat.h> @@ -172,6 +174,9 @@ static SCM *scm_loc_load_path; /* List of extensions we try adding to the filenames. */ static SCM *scm_loc_load_extensions; +/* Like %load-extensions, but for compiled files. */ +static SCM *scm_loc_load_compiled_extensions; + SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, (SCM path, SCM tail), @@ -206,9 +211,17 @@ scm_init_load_path () SCM path = SCM_EOL; #ifdef SCM_LIBRARY_DIR - path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR), - scm_from_locale_string (SCM_LIBRARY_DIR), - scm_from_locale_string (SCM_PKGDATA_DIR)); + env = getenv ("GUILE_SYSTEM_PATH"); + if (env && strcmp (env, "") == 0) + /* special-case interpret system-path=="" as meaning no system path instead + of '("") */ + ; + else if (env) + path = scm_parse_path (scm_from_locale_string (env), path); + else + path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR), + scm_from_locale_string (SCM_LIBRARY_DIR), + scm_from_locale_string (SCM_PKGDATA_DIR)); #endif /* SCM_LIBRARY_DIR */ env = getenv ("GUILE_LOAD_PATH"); @@ -291,14 +304,33 @@ stringbuf_cat (struct stringbuf *buf, char *str) } +static int +scm_c_string_has_an_ext (char *str, size_t len, SCM extensions) +{ + for (; !scm_is_null (extensions); extensions = SCM_CDR (extensions)) + { + char *ext; + size_t extlen; + int match; + ext = scm_to_locale_string (SCM_CAR (extensions)); + extlen = strlen (ext); + match = (len > extlen && str[len - extlen - 1] == '.' + && strncmp (str + (len - extlen), ext, extlen) == 0); + free (ext); + if (match) + return 1; + } + return 0; +} + /* Search PATH for a directory containing a file named FILENAME. The file must be readable, and not a directory. If we find one, return its full filename; otherwise, return #f. If FILENAME is absolute, return it unchanged. If given, EXTENSIONS is a list of strings; for each directory in PATH, we search for FILENAME concatenated with each EXTENSION. */ -SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, - (SCM path, SCM filename, SCM extensions), +SCM_DEFINE (scm_search_path, "search-path", 2, 2, 0, + (SCM path, SCM filename, SCM extensions, SCM require_exts), "Search @var{path} for a directory containing a file named\n" "@var{filename}. The file must be readable, and not a directory.\n" "If we find one, return its full filename; otherwise, return\n" @@ -316,6 +348,9 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, if (SCM_UNBNDP (extensions)) extensions = SCM_EOL; + if (SCM_UNBNDP (require_exts)) + require_exts = SCM_BOOL_F; + scm_dynwind_begin (0); filename_chars = scm_to_locale_string (filename); @@ -334,8 +369,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, if (filename_len >= 1 && filename_chars[0] == '/') #endif { + SCM res = filename; + if (scm_is_true (require_exts) && + !scm_c_string_has_an_ext (filename_chars, filename_len, + extensions)) + res = SCM_BOOL_F; + scm_dynwind_end (); - return filename; + return res; } /* If FILENAME has an extension, don't try to add EXTENSIONS to it. */ @@ -348,6 +389,15 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, { if (*endp == '.') { + if (scm_is_true (require_exts) && + !scm_c_string_has_an_ext (filename_chars, filename_len, + extensions)) + { + /* This filename has an extension, but not one of the right + ones... */ + scm_dynwind_end (); + return SCM_BOOL_F; + } /* This filename already has an extension, so cancel the list of extensions. */ extensions = SCM_EOL; @@ -453,7 +503,7 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL); if (scm_ilength (exts) < 0) SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL); - return scm_search_path (path, filename, exts); + return scm_search_path (path, filename, exts, SCM_UNDEFINED); } #undef FUNC_NAME @@ -466,15 +516,51 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, "an error is signalled.") #define FUNC_NAME s_scm_primitive_load_path { - SCM full_filename; + SCM full_filename, compiled_filename; full_filename = scm_sys_search_load_path (filename); + compiled_filename = scm_search_path (*scm_loc_load_path, + filename, + *scm_loc_load_compiled_extensions, + SCM_BOOL_T); - if (scm_is_false (full_filename)) + if (scm_is_false (full_filename) && scm_is_false (compiled_filename)) SCM_MISC_ERROR ("Unable to find file ~S in load path", scm_list_1 (filename)); - return scm_primitive_load (full_filename); + if (scm_is_false (compiled_filename)) + return scm_primitive_load (full_filename); + + if (scm_is_false (full_filename)) + return scm_load_compiled_with_vm (compiled_filename); + + { + char *source, *compiled; + struct stat stat_source, stat_compiled; + + source = scm_to_locale_string (full_filename); + compiled = scm_to_locale_string (compiled_filename); + + if (stat (source, &stat_source) == 0 + && stat (compiled, &stat_compiled) == 0 + && stat_source.st_mtime <= stat_compiled.st_mtime) + { + free (source); + free (compiled); + return scm_load_compiled_with_vm (compiled_filename); + } + else + { + scm_puts (";;; note: source file ", scm_current_error_port ()); + scm_puts (source, scm_current_error_port ()); + scm_puts (" newer than compiled ", scm_current_error_port ()); + scm_puts (compiled, scm_current_error_port ()); + scm_puts ("\n", scm_current_error_port ()); + free (source); + free (compiled); + return scm_primitive_load (full_filename); + } + } } #undef FUNC_NAME @@ -514,6 +600,9 @@ scm_init_load () = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", scm_list_2 (scm_from_locale_string (".scm"), scm_nullstr))); + scm_loc_load_compiled_extensions + = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-extensions", + scm_list_1 (scm_from_locale_string (".go")))); scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); the_reader = scm_make_fluid (); diff --git a/libguile/load.h b/libguile/load.h index 57cc7e8ac..87f336e1e 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -31,7 +31,7 @@ SCM_API SCM scm_c_primitive_load (const char *filename); SCM_API SCM scm_sys_package_data_dir (void); SCM_API SCM scm_sys_library_dir (void); SCM_API SCM scm_sys_site_dir (void); -SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts); +SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts, SCM require_exts); SCM_API SCM scm_sys_search_load_path (SCM filename); SCM_API SCM scm_primitive_load_path (SCM filename); SCM_API SCM scm_c_primitive_load_path (const char *filename); diff --git a/libguile/macros.c b/libguile/macros.c index 10464eb1d..d132c0159 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -31,6 +31,7 @@ #include "libguile/deprecation.h" #include "libguile/validate.h" +#include "libguile/programs.h" #include "libguile/macros.h" #include "libguile/private-options.h" @@ -47,7 +48,7 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate) || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, macro, port, pstate))) { - if (!SCM_CLOSUREP (code)) + if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) scm_puts ("#<primitive-", port); else scm_puts ("#<", port); @@ -223,9 +224,15 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, "Return the transformer of the macro @var{m}.") #define FUNC_NAME s_scm_macro_transformer { + SCM data; + SCM_VALIDATE_SMOB (1, m, macro); - return ((SCM_CLOSUREP (SCM_PACK (SCM_SMOB_DATA (m)))) ? - SCM_PACK(SCM_SMOB_DATA (m)) : SCM_BOOL_F); + data = SCM_PACK (SCM_SMOB_DATA (m)); + + if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data)) + return data; + else + return SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/modules.c b/libguile/modules.c index 24b5ad9d8..beee0e2a5 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -339,6 +339,8 @@ resolve_duplicate_binding (SCM module, SCM sym, return result; } +SCM scm_pre_modules_obarray; + /* Lookup SYM as an imported variable of MODULE. */ static inline SCM module_imported_variable (SCM module, SCM sym) @@ -465,6 +467,9 @@ SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0, SCM_VALIDATE_SYMBOL (2, sym); + if (scm_is_false (module)) + return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED); + /* 1. Check module obarray */ var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); if (SCM_BOUND_THING_P (var)) @@ -618,6 +623,25 @@ SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0, } #undef FUNC_NAME +SCM_SYMBOL (sym_sys_module_public_interface, "%module-public-interface"); + +SCM_DEFINE (scm_module_public_interface, "module-public-interface", 1, 0, 0, + (SCM module), + "Return the public interface of @var{module}.\n\n" + "If @var{module} has no public interface, @code{#f} is returned.") +#define FUNC_NAME s_scm_module_public_interface +{ + SCM var; + + SCM_VALIDATE_MODULE (1, module); + var = scm_module_local_variable (module, sym_sys_module_public_interface); + if (scm_is_true (var)) + return SCM_VARIABLE_REF (var); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + /* scm_sym2var * * looks up the variable bound to SYM according to PROC. PROC should be @@ -631,8 +655,6 @@ SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0, * the scm_pre_modules_obarray (a `eq' hash table). */ -SCM scm_pre_modules_obarray; - SCM scm_sym2var (SCM sym, SCM proc, SCM definep) #define FUNC_NAME "scm_sym2var" diff --git a/libguile/modules.h b/libguile/modules.h index afac9f4e4..4f42e1888 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -100,6 +100,7 @@ SCM_API void scm_c_export (const char *name, ...); SCM_API SCM scm_sym2var (SCM sym, SCM thunk, SCM definep); +SCM_API SCM scm_module_public_interface (SCM module); SCM_API SCM scm_module_import_interface (SCM module, SCM sym); SCM_API SCM scm_module_lookup_closure (SCM module); SCM_API SCM scm_module_transformer (SCM module); diff --git a/libguile/objcodes.c b/libguile/objcodes.c new file mode 100644 index 000000000..6891e8a6a --- /dev/null +++ b/libguile/objcodes.c @@ -0,0 +1,301 @@ +/* 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" + + +/* + * 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 + + +/* + * 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 + + +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: +*/ diff --git a/libguile/objcodes.h b/libguile/objcodes.h new file mode 100644 index 000000000..2cedefa98 --- /dev/null +++ b/libguile/objcodes.h @@ -0,0 +1,78 @@ +/* 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: +*/ diff --git a/libguile/procs.c b/libguile/procs.c index 9895548d5..6b4b586b6 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -31,6 +31,7 @@ #include "libguile/validate.h" #include "libguile/procs.h" +#include "libguile/programs.h" @@ -221,7 +222,9 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, obj = SCM_PROCEDURE (obj); goto again; default: - ; + if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0) + return SCM_BOOL_T; + /* otherwise fall through */ } } return SCM_BOOL_F; diff --git a/libguile/programs.c b/libguile/programs.c new file mode 100644 index 000000000..122c1b776 --- /dev/null +++ b/libguile/programs.c @@ -0,0 +1,294 @@ +/* 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 "modules.h" +#include "programs.h" +#include "vm.h" + + +scm_t_bits scm_tc16_program; + +static SCM zero_vector; +static SCM write_program = SCM_BOOL_F; + +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; + p->module = scm_current_module (); + + /* 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); + if (!SCM_PROGRAM_P (program)) + abort (); + *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); + scm_gc_mark (p->module); + 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); +} + +static int +program_print (SCM program, SCM port, scm_print_state *pstate) +{ + static int print_error = 0; + + if (SCM_FALSEP (write_program) && scm_module_system_booted_p) + write_program = scm_module_local_variable + (scm_c_resolve_module ("system vm program"), + scm_from_locale_symbol ("write-program")); + + if (SCM_FALSEP (write_program) || print_error) + return scm_smob_print (program, port, pstate); + + print_error = 1; + scm_call_2 (SCM_VARIABLE_REF (write_program), program, port); + print_error = 0; + return 1; +} + + +/* + * 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_module, "program-module", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_module +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_DATA (program)->module; +} +#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 + + + +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); + scm_set_smob_print (scm_tc16_program, program_print); +} + +void +scm_init_programs (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "programs.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/programs.h b/libguile/programs.h new file mode 100644 index 000000000..0f1b57dd3 --- /dev/null +++ b/libguile/programs.h @@ -0,0 +1,95 @@ +/* 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 module; /* resolve bindings with respect to this module */ + 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_module (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: +*/ diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h new file mode 100644 index 000000000..beecf0fc2 --- /dev/null +++ b/libguile/vm-bootstrap.h @@ -0,0 +1,53 @@ +/* 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: +*/ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c new file mode 100644 index 000000000..86b19de54 --- /dev/null +++ b/libguile/vm-engine.c @@ -0,0 +1,226 @@ +/* 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; + int nvalues = 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); + + /* could do this if we reified all vm stacks -- for now, don't bother changing + *the-vm* + if (scm_fluid_ref (scm_the_vm_fluid) != vm) + scm_dynwind_fluid (scm_the_vm_fluid, vm); + */ + +#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[6] = {scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt}; + bytes[1] = scm_ilength (args); /* FIXME: argument overflow */ + program = scm_c_make_program (bytes, 6, 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; + + vm_error_no_values: + err_msg = scm_from_locale_string ("VM: 0-valued return"); + err_args = SCM_EOL; + goto vm_error; + + vm_error_not_enough_values: + err_msg = scm_from_locale_string ("VM: Not enough values for mv-bind"); + err_args = SCM_EOL; + goto vm_error; + + vm_error_no_such_module: + err_msg = scm_from_locale_string ("VM: No such module: ~A"); + 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: +*/ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h new file mode 100644 index 000000000..0d0c03d8a --- /dev/null +++ b/libguile/vm-engine.h @@ -0,0 +1,453 @@ +/* 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 */ + + +/* + * 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 + + +/* + * Cache/Sync + */ + +#define CACHE_REGISTER() \ +{ \ + ip = vp->ip; \ + sp = vp->sp; \ + fp = vp->fp; \ + stack_base = fp ? SCM_FRAME_UPPER_ADDRESS (fp) - 1 : vp->stack_base; \ +} + +#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 (); \ +} + + +/* + * 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 + + +/* + * 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) + + +/* + * 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) + + +/* 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 */ + + +#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) + + +/* + * 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 (); \ +} + + +/* + * 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 */ +/* When this is called, bp points to the new program data, + and the arguments are already on the stack */ +#define NEW_FRAME() \ +{ \ + int i; \ + SCM *dl, *data; \ + scm_byte_t *ra = ip; \ + \ + /* Save old registers */ \ + ra = ip; \ + dl = fp; \ + \ + /* New registers */ \ + fp = sp - bp->nargs + 1; \ + data = SCM_FRAME_DATA_ADDRESS (fp); \ + sp = data + 4; \ + CHECK_OVERFLOW (); \ + stack_base = sp; \ + ip = bp->base; \ + \ + /* Init local variables */ \ + for (i=bp->nlocs; i; i--) \ + data[-i] = SCM_UNDEFINED; \ + \ + /* Create external variables */ \ + external = bp->external; \ + for (i = 0; i < bp->nexts; i++) \ + CONS (external, SCM_UNDEFINED, external); \ + \ + /* Set frame data */ \ + data[4] = (SCM)ra; \ + data[3] = 0x0; \ + data[2] = (SCM)dl; \ + data[1] = SCM_BOOL_F; \ + data[0] = external; \ +} + +#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs] + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h new file mode 100644 index 000000000..cccb56b9f --- /dev/null +++ b/libguile/vm-expand.h @@ -0,0 +1,103 @@ +/* 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: +*/ diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c new file mode 100644 index 000000000..72436f0d5 --- /dev/null +++ b/libguile/vm-i-loader.c @@ -0,0 +1,230 @@ +/* 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_PROGRAM_P (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)) + { + scm_t_uint16 s = (scm_t_uint16)SCM_I_INUM (x); + /* 16-bit representation */ + p->nargs = (s >> 12) & 0x0f; /* 15-12 bits */ + p->nrest = (s >> 11) & 0x01; /* 11 bit */ + p->nlocs = (s >> 4) & 0x7f; /* 10-04 bits */ + p->nexts = s & 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 what; + POP (what); + SYNC_REGISTER (); + if (SCM_LIKELY (SCM_SYMBOLP (what))) + { + PUSH (scm_lookup (what)); /* might longjmp */ + } + else + { + SCM mod; + /* compilation of @ or @@ + `what' is a three-element list: (MODNAME SYM INTERFACE?) + INTERFACE? is #t if we compiled @ or #f if we compiled @@ + */ + mod = scm_resolve_module (SCM_CAR (what)); + if (scm_is_true (SCM_CADDR (what))) + mod = scm_module_public_interface (mod); + if (SCM_FALSEP (mod)) + { + err_args = SCM_LIST1 (SCM_CAR (what)); + goto vm_error_no_such_module; + } + /* might longjmp */ + PUSH (scm_module_lookup (mod, SCM_CADR (what))); + } + + 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: +*/ diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c new file mode 100644 index 000000000..912c91bf2 --- /dev/null +++ b/libguile/vm-i-scheme.c @@ -0,0 +1,275 @@ +/* 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 */ + + +/* + * Predicates + */ + +#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) + +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)); +} + + +/* + * 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); +} + + +/* + * 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); +} + + +/* + * Numeric functions + */ + +#undef FUNC2 +#define FUNC2(CFUNC,SFUNC) \ +{ \ + ARGS2 (x, y); \ + if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ + { \ + scm_t_bits 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: +*/ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c new file mode 100644 index 000000000..87d3a533a --- /dev/null +++ b/libguile/vm-i-system.c @@ -0,0 +1,1083 @@ +/* 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 */ + + +/* + * 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 (); + nvalues = SCM_I_INUM (*sp--); + if (nvalues == 1) + POP (ret); + else + { + POP_LIST (nvalues); + POP (ret); + SYNC_REGISTER (); + ret = scm_values (ret); + } + + { +#ifdef THE_GOVERNMENT_IS_AFTER_ME + if (sp != stack_base) + abort (); + if (stack_base != SCM_FRAME_UPPER_ADDRESS (fp) - 1) + abort (); +#endif + + /* Restore registers */ + sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; + ip = NULL; + fp = SCM_FRAME_DYNAMIC_LINK (fp); + } + SYNC_ALL (); + 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; +} + + +/* + * 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); + SYNC_REGISTER (); + *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 (); + SYNC_REGISTER (); + *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; +} + + +/* + * 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 what; + CHECK_OBJECT (objnum); + what = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (what)) + { + SYNC_REGISTER (); + if (SCM_LIKELY (SCM_SYMBOLP (what))) + { + if (SCM_LIKELY (scm_module_system_booted_p + && scm_is_true (bp->module))) + /* might longjmp */ + what = scm_module_lookup (bp->module, what); + else + what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + } + else + { + SCM mod; + /* compilation of @ or @@ + `what' is a three-element list: (MODNAME SYM INTERFACE?) + INTERFACE? is #t if we compiled @ or #f if we compiled @@ + */ + mod = scm_resolve_module (SCM_CAR (what)); + if (scm_is_true (SCM_CADDR (what))) + mod = scm_module_public_interface (mod); + if (SCM_FALSEP (mod)) + { + err_args = SCM_LIST1 (mod); + goto vm_error_no_such_module; + } + /* might longjmp */ + what = scm_module_lookup (mod, SCM_CADR (what)); + } + + if (!VARIABLE_BOUNDP (what)) + { + err_args = SCM_LIST1 (what); + goto vm_error_unbound; + } + + OBJECT_SET (objnum, what); + } + + PUSH (VARIABLE_REF (what)); + 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 what; + CHECK_OBJECT (objnum); + what = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (what)) + { + SYNC_BEFORE_GC (); + if (SCM_LIKELY (SCM_SYMBOLP (what))) + { + if (SCM_LIKELY (scm_module_system_booted_p + && scm_is_true (bp->module))) + /* might longjmp */ + what = scm_module_lookup (bp->module, what); + else + what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + } + else + { + SCM mod; + /* compilation of @ or @@ + `what' is a three-element list: (MODNAME SYM INTERFACE?) + INTERFACE? is #t if we compiled @ or #f if we compiled @@ + */ + mod = scm_resolve_module (SCM_CAR (what)); + if (scm_is_true (SCM_CADDR (what))) + mod = scm_module_public_interface (mod); + if (SCM_FALSEP (mod)) + { + err_args = SCM_LIST1 (what); + goto vm_error_no_such_module; + } + /* might longjmp */ + what = scm_module_lookup (mod, SCM_CADR (what)); + } + + OBJECT_SET (objnum, what); + } + + VARIABLE_SET (what, *sp); + DROP (); + NEXT; +} + + +/* + * branch and jump + */ + +/* offset must be a signed short!!! */ +#define FETCH_OFFSET(offset) \ +{ \ + int h = FETCH (); \ + int l = FETCH (); \ + offset = (h << 8) + l; \ +} + +#define BR(p) \ +{ \ + signed short offset; \ + FETCH_OFFSET (offset); \ + 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)); +} + + +/* + * 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; + 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); + /* FIXME what if SCM_VALUESP(*sp) */ + NEXT; + } + /* + * Continuation call + */ + if (SCM_VM_CONT_P (x)) + { + program = x; + vm_call_continuation: + /* Check the number of arguments */ + /* FIXME multiple args */ + 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 (goto_args, "goto/args", 1, -1, 1) +{ + register SCM x; + nargs = FETCH (); + vm_goto_args: + 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; + } + + /* + * Tail call, but not to self -- reuse the frame, keeping the ra and dl + */ + if (SCM_PROGRAM_P (x)) + { + SCM *data, *tail_args, *dl; + int i; + scm_byte_t *ra, *mvra; + + EXIT_HOOK (); + + /* save registers */ + tail_args = stack_base + 2; + ra = SCM_FRAME_RETURN_ADDRESS (fp); + mvra = SCM_FRAME_MV_RETURN_ADDRESS (fp); + dl = SCM_FRAME_DYNAMIC_LINK (fp); + + /* switch programs */ + fp[-1] = program = x; + CACHE_PROGRAM (); + INIT_ARGS (); + nargs = bp->nargs; + + /* new registers -- logically this would be better later, but let's make + sure we have space for the locals now */ + data = SCM_FRAME_DATA_ADDRESS (fp); + ip = bp->base; + stack_base = data + 4; + sp = stack_base; + CHECK_OVERFLOW (); + + /* copy args, bottom-up */ + for (i = 0; i < nargs; i++) + fp[i] = tail_args[i]; + + /* init locals */ + for (i = bp->nlocs; i; i--) + data[-i] = SCM_UNDEFINED; + + /* and the external variables */ + external = bp->external; + for (i = 0; i < bp->nexts; i++) + CONS (external, SCM_UNDEFINED, external); + + /* Set frame data */ + data[4] = (SCM)ra; + data[3] = (SCM)mvra; + data[2] = (SCM)dl; + data[1] = SCM_BOOL_F; + data[0] = external; + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; + } +#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); + /* FIXME what if SCM_VALUESP(*sp) */ + goto vm_return; + } + + program = x; + + /* + * Continuation call + */ + if (SCM_VM_CONT_P (program)) + goto vm_call_continuation; + + goto vm_error_wrong_type_apply; +} + +VM_DEFINE_INSTRUCTION (goto_nargs, "goto/nargs", 0, 0, 1) +{ + SCM x; + POP (x); + nargs = scm_to_int (x); + /* FIXME: should truncate values? */ + goto vm_goto_args; +} + +VM_DEFINE_INSTRUCTION (call_nargs, "call/nargs", 0, 0, 1) +{ + SCM x; + POP (x); + nargs = scm_to_int (x); + /* FIXME: should truncate values? */ + goto vm_call; +} + +VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1) +{ + SCM x; + signed short offset; + + nargs = FETCH (); + FETCH_OFFSET (offset); + + x = sp[-nargs]; + + /* + * Subprogram call + */ + if (SCM_PROGRAM_P (x)) + { + program = x; + CACHE_PROGRAM (); + INIT_ARGS (); + NEW_FRAME (); + SCM_FRAME_DATA_ADDRESS (fp)[3] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset); + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; + } + /* + * 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); + if (SCM_VALUESP (*sp)) + { + SCM values, len; + POP (values); + values = scm_struct_ref (values, SCM_INUM0); + len = scm_length (values); + for (; !SCM_NULLP (values); values = SCM_CDR (values)) + PUSH (SCM_CAR (values)); + PUSH (len); + ip += offset; + } + NEXT; + } + /* + * Continuation call + */ + if (SCM_VM_CONT_P (x)) + { + program = x; + goto vm_call_continuation; + } + + program = x; + 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 (goto_apply, "goto/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_goto_args; +} + +VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 0, 1, 1) +{ + int first; + SCM proc, cont; + POP (proc); + SYNC_ALL (); + cont = scm_make_continuation (&first); + if (first) + { + PUSH (proc); + PUSH (cont); + nargs = 1; + goto vm_call; + } + else if (SCM_VALUESP (cont)) + { + /* multiple values returned to continuation */ + SCM values; + values = scm_struct_ref (cont, SCM_INUM0); + if (SCM_NULLP (values)) + goto vm_error_wrong_num_args; + /* non-tail context does not accept multiple values? */ + PUSH (SCM_CAR (values)); + NEXT; + } + else + { + PUSH (cont); + NEXT; + } +} + +VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 0, 1, 1) +{ + int first; + SCM proc, cont; + POP (proc); + SYNC_ALL (); + cont = scm_make_continuation (&first); + if (first) + { + PUSH (proc); + PUSH (cont); + nargs = 1; + goto vm_goto_args; + } + else if (SCM_VALUESP (cont)) + { + /* multiple values returned to continuation */ + SCM values; + values = scm_struct_ref (cont, SCM_INUM0); + nvalues = scm_ilength (values); + for (; !SCM_NULLP (values); values = SCM_CDR (values)) + PUSH (SCM_CAR (values)); + goto vm_return_values; + } + else + { + PUSH (cont); + goto vm_return; + } +} + +VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1) +{ + vm_return: + EXIT_HOOK (); + RETURN_HOOK (); + { + SCM ret, *data; + data = SCM_FRAME_DATA_ADDRESS (fp); + + POP (ret); +#ifdef THE_GOVERNMENT_IS_AFTER_ME + if (sp != stack_base) + abort (); + if (stack_base != data + 4) + abort (); +#endif + + /* Restore registers */ + sp = SCM_FRAME_LOWER_ADDRESS (fp); + ip = SCM_FRAME_BYTE_CAST (data[4]); + fp = SCM_FRAME_STACK_CAST (data[2]); + stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; + + /* Set return value (sp is already pushed) */ + *sp = ret; + } + + /* Restore the last program */ + program = SCM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); + CACHE_EXTERNAL (); + CHECK_IP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1) +{ + /* nvalues declared at top level, because for some reason gcc seems to think + that perhaps it might be used without declaration. Fooey to that, I say. */ + SCM *data; + + nvalues = FETCH (); + vm_return_values: + EXIT_HOOK (); + RETURN_HOOK (); + + data = SCM_FRAME_DATA_ADDRESS (fp); +#ifdef THE_GOVERNMENT_IS_AFTER_ME + if (stack_base != data + 4) + abort (); +#endif + + /* data[3] is the mv return address */ + if (nvalues != 1 && data[3]) + { + int i; + /* Restore registers */ + sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; + ip = SCM_FRAME_BYTE_CAST (data[3]); /* multiple value ra */ + fp = SCM_FRAME_STACK_CAST (data[2]); + + /* Push return values, and the number of values */ + for (i = 0; i < nvalues; i++) + *++sp = stack_base[1+i]; + *++sp = SCM_I_MAKINUM (nvalues); + + /* Finally set new stack_base */ + stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; + } + else if (nvalues >= 1) + { + /* Multiple values for a single-valued continuation -- here's where I + break with guile tradition and try and do something sensible. (Also, + this block handles the single-valued return to an mv + continuation.) */ + /* Restore registers */ + sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; + ip = SCM_FRAME_BYTE_CAST (data[4]); /* single value ra */ + fp = SCM_FRAME_STACK_CAST (data[2]); + + /* Push first value */ + *++sp = stack_base[1]; + + /* Finally set new stack_base */ + stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; + } + else + goto vm_error_no_values; + + /* Restore the last program */ + program = SCM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); + CACHE_EXTERNAL (); + CHECK_IP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1) +{ + SCM l; + + nvalues = FETCH (); +#ifdef THE_GOVERNMENT_IS_AFTER_ME + if (nvalues < 1) + abort (); +#endif + + nvalues--; + POP (l); + while (SCM_CONSP (l)) + { + PUSH (SCM_CAR (l)); + l = SCM_CDR (l); + nvalues++; + } + + goto vm_return_values; +} + +VM_DEFINE_INSTRUCTION (truncate_values, "truncate-values", 2, -1, -1) +{ + SCM x; + int nbinds, rest; + POP (x); + nvalues = scm_to_int (x); + nbinds = FETCH (); + rest = FETCH (); + + if (rest) + nbinds--; + + if (nvalues < nbinds) + goto vm_error_not_enough_values; + + if (rest) + POP_LIST (nvalues - nbinds); + else + DROPN (nvalues - nbinds); + + NEXT; +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm.c b/libguile/vm.c new file mode 100644 index 000000000..b93d7125e --- /dev/null +++ b/libguile/vm.c @@ -0,0 +1,728 @@ +/* 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 ()); \ +} + + +/* + * VM Continuation + */ + +scm_t_bits scm_tc16_vm_cont; + +struct scm_vm_cont { + scm_byte_t *ip; + scm_t_ptrdiff sp; + scm_t_ptrdiff fp; + scm_t_ptrdiff stack_size; + SCM *stack_base; +}; + + +#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) +#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT)) + +static SCM +vm_cont_mark (SCM obj) +{ + size_t size; + SCM *stack; + + stack = SCM_VM_CONT_DATA (obj)->stack_base; + size = SCM_VM_CONT_DATA (obj)->stack_size; + + /* we could be smarter about this. */ + scm_mark_locations ((SCM_STACKITEM *) stack, size); + + return SCM_BOOL_F; +} + +static scm_sizet +vm_cont_free (SCM obj) +{ + struct scm_vm_cont *p = SCM_VM_CONT_DATA (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; +} + +static SCM +capture_vm_cont (struct scm_vm *vp) +{ + struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); + p->stack_size = vp->sp - vp->stack_base + 1; + p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), + "capture_vm_cont"); + p->ip = vp->ip; + p->sp = vp->sp - vp->stack_base; + p->fp = vp->fp - vp->stack_base; + memcpy (p->stack_base, vp->stack_base, p->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_cont *p = SCM_VM_CONT_DATA (cont); + if (vp->stack_size < p->stack_size) + { + /* puts ("FIXME: Need to expand"); */ + abort (); + } + vp->ip = p->ip; + vp->sp = vp->stack_base + p->sp; + vp->fp = vp->stack_base + p->fp; + memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM)); +} + +/* In theory, a number of vm instances can be active in the call trace, and we + only want to reify the continuations of those in the current continuation + root. I don't see a nice way to do this -- ideally it would involve dynwinds, + and previous values of the *the-vm* fluid within the current continuation + root. But we don't have access to continuation roots in the dynwind stack. + So, just punt for now -- take the current value of *the-vm*. + + While I'm on the topic, ideally we could avoid copying the C stack if the + continuation root is inside VM code, and call/cc was invoked within that same + call to vm_run; but that's currently not implemented. + */ +SCM +scm_vm_capture_continuations (void) +{ + SCM vm = scm_the_vm (); + return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL); +} + +void +scm_vm_reinstate_continuations (SCM conts) +{ + for (; conts != SCM_EOL; conts = SCM_CDR (conts)) + reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts)); +} + +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; +} + + +/* + * VM Internal functions + */ + +static SCM sym_vm_run; +static SCM sym_vm_error; +static SCM sym_debug; + +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; +} + + +/* + * 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; + +SCM scm_the_vm_fluid; + +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 + 1 - vp->stack_base)); + + /* 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 +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 +{ + SCM ret; + + if (SCM_NFALSEP ((ret = scm_fluid_ref (scm_the_vm_fluid)))) + return ret; + + ret = make_vm (); + scm_fluid_set_x (scm_the_vm_fluid, ret); + return ret; +} +#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 + + +/* + * Initialize + */ + +SCM scm_load_compiled_with_vm (SCM file) +{ + SCM program = scm_objcode_to_program (scm_load_objcode (file)); + + return vm_run (scm_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); + + scm_the_vm_fluid = scm_permanent_object (scm_make_fluid ()); + scm_fluid_set_x (scm_the_vm_fluid, make_vm ()); + scm_c_define ("*the-vm*", scm_the_vm_fluid); + + scm_c_define ("load-compiled", + scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0, + scm_load_compiled_with_vm)); + + sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run")); + sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error")); + sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug")); + + 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: +*/ diff --git a/libguile/vm.h b/libguile/vm.h new file mode 100644 index 000000000..7e6ae613b --- /dev/null +++ b/libguile/vm.h @@ -0,0 +1,123 @@ +/* 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> +#include <libguile/programs.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 */ +}; + +extern SCM scm_the_vm_fluid; + +#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_vm_capture_continuations (void); +extern void scm_vm_reinstate_continuations (SCM conts); + +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: +*/ diff --git a/m4/labels-as-values.m4 b/m4/labels-as-values.m4 new file mode 100644 index 000000000..3cf7320bd --- /dev/null +++ b/m4/labels-as-values.m4 @@ -0,0 +1,22 @@ +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 +]) diff --git a/module/.cvsignore b/module/.cvsignore new file mode 100644 index 000000000..b4cfc7dd0 --- /dev/null +++ b/module/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +slibcat diff --git a/module/Makefile.am b/module/Makefile.am new file mode 100644 index 000000000..06fde9ae2 --- /dev/null +++ b/module/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = system language diff --git a/module/language/.cvsignore b/module/language/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/Makefile.am b/module/language/Makefile.am new file mode 100644 index 000000000..2e97652fc --- /dev/null +++ b/module/language/Makefile.am @@ -0,0 +1 @@ +SUBDIRS=scheme diff --git a/module/language/elisp/.cvsignore b/module/language/elisp/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/elisp/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm new file mode 100644 index 000000000..a35c44112 --- /dev/null +++ b/module/language/elisp/spec.scm @@ -0,0 +1,63 @@ +;;; 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)) + + +;;; +;;; 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)))) + + +;;; +;;; Language definition +;;; + +(define-language elisp + #:title "Emacs Lisp" + #:version "0.0" + #:reader read + #:expander id + #:translator translate + ) diff --git a/module/language/ghil/.cvsignore b/module/language/ghil/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/ghil/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/ghil/GPKG.def b/module/language/ghil/GPKG.def new file mode 100644 index 000000000..999d2ef88 --- /dev/null +++ b/module/language/ghil/GPKG.def @@ -0,0 +1,8 @@ +;;; GHIL package definition -*- gscheme -*- + +(define-package ghil + :category Language + :version "0.3" + :author "Keisuke Nishida <kxn30@po.cwru.edu>" + :modules ((spec "spec.scm" gscheme)) + ) diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm new file mode 100644 index 000000000..6afdf0e17 --- /dev/null +++ b/module/language/ghil/spec.scm @@ -0,0 +1,32 @@ +;;; 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) + ) diff --git a/module/language/r5rs/.cvsignore b/module/language/r5rs/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/r5rs/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/r5rs/GPKG.def b/module/language/r5rs/GPKG.def new file mode 100644 index 000000000..5ad52e8c6 --- /dev/null +++ b/module/language/r5rs/GPKG.def @@ -0,0 +1,12 @@ +;;; 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)) + ) diff --git a/module/language/r5rs/core.il b/module/language/r5rs/core.il new file mode 100644 index 000000000..ad40fcc1a --- /dev/null +++ b/module/language/r5rs/core.il @@ -0,0 +1,325 @@ +;;; 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 diff --git a/module/language/r5rs/expand.scm b/module/language/r5rs/expand.scm new file mode 100644 index 000000000..45b722717 --- /dev/null +++ b/module/language/r5rs/expand.scm @@ -0,0 +1,81 @@ +;;; 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) diff --git a/module/language/r5rs/null.il b/module/language/r5rs/null.il new file mode 100644 index 000000000..efdc5f398 --- /dev/null +++ b/module/language/r5rs/null.il @@ -0,0 +1,20 @@ +;;; 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: diff --git a/module/language/r5rs/psyntax.pp b/module/language/r5rs/psyntax.pp new file mode 100644 index 000000000..ef9ca0aa9 --- /dev/null +++ b/module/language/r5rs/psyntax.pp @@ -0,0 +1,14552 @@ +;;; 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))) diff --git a/module/language/r5rs/psyntax.ss b/module/language/r5rs/psyntax.ss new file mode 100644 index 000000000..c8ac3e503 --- /dev/null +++ b/module/language/r5rs/psyntax.ss @@ -0,0 +1,3202 @@ +;;; 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)))))))))) + diff --git a/module/language/r5rs/spec.scm b/module/language/r5rs/spec.scm new file mode 100644 index 000000000..b5d19e6d4 --- /dev/null +++ b/module/language/r5rs/spec.scm @@ -0,0 +1,64 @@ +;;; 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)) + + +;;; +;;; 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)))))) + + +;;; +;;; 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) + ) diff --git a/module/language/scheme/.cvsignore b/module/language/scheme/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/scheme/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/scheme/Makefile.am b/module/language/scheme/Makefile.am new file mode 100644 index 000000000..8a2c32b7c --- /dev/null +++ b/module/language/scheme/Makefile.am @@ -0,0 +1,3 @@ +SOURCES = translate.scm spec.scm +modpath = language/scheme +include $(top_srcdir)/guilec.mk diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm new file mode 100644 index 000000000..2c9bc4fb6 --- /dev/null +++ b/module/language/scheme/spec.scm @@ -0,0 +1,51 @@ +;;; 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 + #:evaluator eval + #:printer write + ) diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm new file mode 100644 index 000000000..0d313e9fd --- /dev/null +++ b/module/language/scheme/translate.scm @@ -0,0 +1,466 @@ +;;; 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 ((ice-9 syncase) #:select (sc-macro)) + #:use-module ((system base compile) #:select (syntax-error)) + #:export (translate)) + + +(define (translate x e) + (call-with-ghil-environment (make-ghil-toplevel-env) '() + (lambda (env vars) + (make-ghil-lambda env #f vars #f '() (trans env (location x) x))))) + + +;;; +;;; 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)) + +;; Looks up transformers relative to the current module at +;; compilation-time. See also the discussion of ghil-lookup in ghil.scm. +(define (lookup-transformer head retrans) + (let* ((mod (current-module)) + (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 + ((assq-ref custom-transformer-table val)) + + ((defmacro? val) + (lambda (env loc exp) + (retrans (apply (defmacro-transformer val) (cdr exp))))) + + ((eq? 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))))))) + + ((primitive-macro? val) + (syntax-error #f "unhandled primitive macro" head)) + + ((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 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-var-for-ref! 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 custom-transformer-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 0)))) + + (define + ;; (define NAME VAL) + ((,name ,val) (guard (symbol? name) + (ghil-toplevel-env? (ghil-env-parent e))) + (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) name) + (maybe-name-value! (retrans val) name))) + ;; (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-var-for-set! e name) (retrans val))) + + ;; FIXME: Would be nice to verify the values of @ and @@ relative + ;; to imported modules... + (((@ ,modname ,name) ,val) (guard (symbol? name) + (list? modname) + (and-map symbol? modname) + (not (ghil-var-is-bound? e '@))) + (make-ghil-set e l (ghil-var-at-module! e modname name #t) + (retrans val))) + + (((@@ ,modname ,name) ,val) (guard (symbol? name) + (list? modname) + (and-map symbol? modname) + (not (ghil-var-is-bound? e '@@))) + (make-ghil-set e l (ghil-var-at-module! e modname name #f) + (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)))))))) + + ;; FIXME not hygienic + (delay + ((,expr) + (retrans `(make-promise (lambda () ,expr))))) + + (@ + ((,modname ,sym) + (make-ghil-ref e l (ghil-var-at-module! e modname sym #t)))) + + (@@ + ((,modname ,sym) + (make-ghil-ref e l (ghil-var-at-module! e modname sym #f)))) + + (eval-case + (,clauses + (retrans + `(begin + ;; Compilation of toplevel units is always wrapped in a lambda + ,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent 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)))))))))))) + + ;; FIXME: not hygienic, relies on @apply not being shadowed + (apply + (,args (retrans `(@apply ,@args)))) + + (@apply + ((,proc ,arg1 . ,args) + (let ((args (cons (retrans arg1) (map retrans args)))) + (cond ((and (symbol? proc) + (not (ghil-var-is-bound? e proc)) + (and=> (module-variable (current-module) proc) + (lambda (var) + (and (variable-bound? var) + (lookup-apply-transformer (variable-ref var)))))) + ;; that is, a variable, not part of this compilation + ;; unit, but defined in the toplevel environment, and has + ;; an apply transformer registered + => (lambda (t) (t e l args))) + (else (make-ghil-inline e l 'apply + (cons (retrans proc) args))))))) + + ;; FIXME: not hygienic, relies on @call-with-values not being shadowed + (call-with-values + ((,producer ,consumer) + (retrans `(@call-with-values ,producer ,consumer))) + (else #f)) + + (@call-with-values + ((,producer ,consumer) + (make-ghil-mv-call e l (retrans producer) (retrans consumer)))) + + ;; FIXME: not hygienic, relies on @call-with-current-continuation + ;; not being shadowed + (call-with-current-continuation + ((,proc) + (retrans `(@call-with-current-continuation ,proc))) + (else #f)) + + (@call-with-current-continuation + ((,proc) + (make-ghil-inline e l 'call/cc (list (retrans proc))))) + + (receive + ((,formals ,producer-exp . ,body) + ;; Lovely, self-referential usage. Not strictly necessary, the + ;; macro would do the trick; but it's good to test the mv-bind + ;; code. + (receive (syms rest) (parse-formals formals) + (call-with-ghil-bindings e syms + (lambda (vars) + (make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp)) + vars rest (trans-body e l body))))))) + + (values + ((,x) (retrans x)) + (,args (make-ghil-values e l (map retrans args)))))) + +(define (lookup-apply-transformer proc) + (cond ((eq? proc values) + (lambda (e l args) + (make-ghil-values* e l args))) + (else #f))) + +(define (trans-quasiquote e l x level) + (cond ((not (pair? x)) x) + ((memq (car x) '(unquote unquote-splicing)) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) + (cond + ((zero? level) + (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 + (list (car x) (trans-quasiquote e l obj (1- level)))))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + ((eq? (car x) 'quasiquote) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level)))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + (else (cons (trans-quasiquote e l (car x) level) + (trans-quasiquote e l (cdr x) level))))) + +(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 (maybe-name-value! val name) + (cond + ((ghil-lambda? val) + (if (not (assq-ref (ghil-lambda-meta val) 'name)) + (set! (ghil-lambda-meta val) + (acons 'name name (ghil-lambda-meta val)))))) + val) + +(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)))))) diff --git a/module/system/.cvsignore b/module/system/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/system/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/system/Makefile.am b/module/system/Makefile.am new file mode 100644 index 000000000..ba1811fe9 --- /dev/null +++ b/module/system/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = base il vm repl diff --git a/module/system/base/.cvsignore b/module/system/base/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/system/base/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/system/base/Makefile.am b/module/system/base/Makefile.am new file mode 100644 index 000000000..794f5d618 --- /dev/null +++ b/module/system/base/Makefile.am @@ -0,0 +1,3 @@ +SOURCES = pmatch.scm syntax.scm compile.scm language.scm +modpath = system/base +include $(top_srcdir)/guilec.mk diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm new file mode 100644 index 000000000..f406eb84f --- /dev/null +++ b/module/system/base/compile.scm @@ -0,0 +1,181 @@ +;;; 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-compile-time loc msg exp)) + +(define-macro (call-with-compile-error-catch thunk) + `(catch 'syntax-error-compile-time + ,thunk + (lambda (key loc msg exp) + (if (pair? loc) + (format (current-error-port) + "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp) + (format (current-error-port) + "unknown location: ~A: ~A~%" msg exp))))) + +(export-syntax call-with-compile-error-catch) + + + +;;; +;;; 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)))) + + +;;; +;;; 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))) diff --git a/module/system/base/language.scm b/module/system/base/language.scm new file mode 100644 index 000000000..609db7df0 --- /dev/null +++ b/module/system/base/language.scm @@ -0,0 +1,48 @@ +;;; 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)) + + +;;; +;;; 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)))) diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm new file mode 100644 index 000000000..260d452dd --- /dev/null +++ b/module/system/base/pmatch.scm @@ -0,0 +1,42 @@ +(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)))) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm new file mode 100644 index 000000000..1fd607268 --- /dev/null +++ b/module/system/base/syntax.scm @@ -0,0 +1,119 @@ +;;; 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 | + + +;;; +;;; 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)))))))))) + + + +;;; +;;; Variants +;;; + +(define-macro (| . rest) + `(begin ,@(map (lambda (def) `(define-record ,def)) rest))) diff --git a/module/system/il/.cvsignore b/module/system/il/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/system/il/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/system/il/Makefile.am b/module/system/il/Makefile.am new file mode 100644 index 000000000..e65c6fd81 --- /dev/null +++ b/module/system/il/Makefile.am @@ -0,0 +1,3 @@ +SOURCES = glil.scm ghil.scm inline.scm compile.scm +modpath = system/il +include $(top_srcdir)/guilec.mk diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm new file mode 100644 index 000000000..838926f7a --- /dev/null +++ b/module/system/il/compile.scm @@ -0,0 +1,433 @@ +;;; 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)) + + +;;; +;;; Stage 2: Optimization +;;; + +(define (lift-variables! env) + (let ((parent-env (ghil-env-parent env))) + (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)))) + +(define (optimize x) + (record-case x + ((<ghil-set> env loc var val) + (make-ghil-set env var (optimize val))) + + ((<ghil-define> env loc var val) + (make-ghil-define env var (optimize val))) + + ((<ghil-if> env loc test then else) + (make-ghil-if env loc (optimize test) (optimize then) (optimize else))) + + ((<ghil-and> env loc exps) + (make-ghil-and env loc (map optimize exps))) + + ((<ghil-or> env loc exps) + (make-ghil-or env loc (map optimize exps))) + + ((<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) + (lift-variables! env) + (make-ghil-bind parent-env loc (map optimize args))) + (else + (make-ghil-call parent-env loc (optimize proc) (map optimize args))))) + (else + (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))) + + ((<ghil-mv-call> env loc producer consumer) + (record-case consumer + ;; (mv-call PRODUCER (lambda ARGS BODY...)) => + ;; (mv-let PRODUCER ARGS BODY...) + ((<ghil-lambda> env loc vars rest meta body) + (lift-variables! env) + (make-ghil-mv-bind producer vars rest body)) + (else + (make-ghil-mv-call env loc (optimize producer) (optimize consumer))))) + + (else x))) + + +;;; +;;; 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))))) + ((toplevel) + (make-glil-toplevel op (ghil-var-name var))) + ((public private) + (make-glil-module op (ghil-var-env var) (ghil-var-name var) + (eq? (ghil-var-kind var) 'public))) + (else (error "Unknown kind of variable:" var)))) + +(define (constant? x) + (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t) + ((pair? x) (and (constant? (car x)) + (constant? (cdr x)))) + ((vector? x) (let lp ((i (vector-length x))) + (or (zero? i) + (and (constant? (vector-ref x (1- i))) + (lp (1- i)))))))) + +(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 (var->binding var) + (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) + (define (push-bindings! loc vars) + (if (not (null? vars)) + (push-code! loc (make-glil-bind (map var->binding 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 '())))) + ((constant? x) + (push-code! #f (make-glil-const #:obj x))) + (else + (error "element of quasiquote can't be compiled" 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)) + (if (not drop) + (push-call! #f 'dup '())) + (push-branch! #f 'br-if L1) + (if (not drop) + (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-mv-bind> env loc producer vars rest body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (let ((MV (make-label))) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! #f (make-glil-const #:obj 1)) + (push-label! MV) + (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) + (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) + (let ((tail-table '((call . goto/args) + (apply . goto/apply) + (call/cc . goto/cc)))) + (cond ((and tail (assq-ref tail-table inline)) + => (lambda (tail-inst) + (push-call! loc tail-inst args))) + (else + (push-call! loc inline args) + (maybe-drop) + (maybe-return))))) + + ((<ghil-values> env loc values) + (cond (tail ;; (lambda () (values 1 2)) + (push-call! loc 'return/values values)) + (drop ;; (lambda () (values 1 2) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (values 10 12) 1)) + (push-code! #f (make-glil-const #:obj 'values)) + (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1)) + (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0)) + (push-call! loc 'call values)))) + + ((<ghil-values*> env loc values) + (cond (tail ;; (lambda () (apply values '(1 2))) + (push-call! loc 'return/values* values)) + (drop ;; (lambda () (apply values '(1 2)) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (apply values '(10 12)) 1)) + (push-code! #f (make-glil-const #:obj 'values)) + (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1)) + (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0)) + (push-call! loc 'apply values)))) + + ((<ghil-call> env loc proc args) + ;; PROC + ;; ARGS... + ;; ([tail-]call NARGS) + (comp-push proc) + (push-call! loc (if tail 'goto/args 'call) args) + (maybe-drop)) + + ((<ghil-mv-call> env loc producer consumer) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label))) + (comp-push consumer) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1)) + (cond ((not tail) + (push-branch! #f 'br POST))) + (push-label! MV) + (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) + (cond ((not tail) + (push-label! POST) + (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)))) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm new file mode 100644 index 000000000..92f4df3c1 --- /dev/null +++ b/module/system/il/ghil.scm @@ -0,0 +1,434 @@ +;;; 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-mv-bind> make-ghil-mv-bind ghil-mv-bind? + ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-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-mv-call> make-ghil-mv-call ghil-mv-call? + ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer + + <ghil-values> make-ghil-values ghil-values? + ghil-values-env ghil-values-loc ghil-values-values + + <ghil-values*> make-ghil-values* ghil-values*? + ghil-values*-env ghil-values*-loc ghil-values*-values + + <ghil-var> make-ghil-var ghil-var? + ghil-var-env ghil-var-name ghil-var-kind ghil-var-index + + <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env? + ghil-toplevel-env-table + + <ghil-env> make-ghil-env ghil-env? + ghil-env-parent ghil-env-table ghil-env-variables + + ghil-env-add! + ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define! + ghil-var-at-module! + call-with-ghil-environment call-with-ghil-bindings)) + + +;;; +;;; 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-mv-bind> env loc producer vars rest body) + (<ghil-lambda> env loc vars rest meta body) + (<ghil-call> env loc proc args) + (<ghil-mv-call> env loc producer consumer) + (<ghil-inline> env loc inline args) + (<ghil-values> env loc values) + (<ghil-values*> env loc values))) + + +;;; +;;; Variables +;;; + +(define-record (<ghil-var> env name kind (index #f))) + + +;;; +;;; Modules +;;; + + +;;; +;;; Environments +;;; + +(define-record (<ghil-env> parent (table '()) (variables '()))) +(define-record (<ghil-toplevel-env> (table '()))) + +(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))) + +(define (force-heap-allocation! var) + (set! (ghil-var-kind var) 'external)) + + + +;;; +;;; Public interface +;;; + +;; The following four functions used to be one, in ghil-lookup. Now they +;; are four, to reflect the different intents. A bit of duplication, but +;; that's OK. The common current is to find out where a variable will be +;; stored at runtime. +;; +;; These functions first search the lexical environments. If the +;; variable is not in the innermost environment, make sure the variable +;; is marked as being "external" so that it goes on the heap. If the +;; variable is being modified (via a set!), also make sure it's on the +;; heap, so that other continuations see the changes to the var. +;; +;; If the variable is not found lexically, it is a toplevel variable, +;; which will be looked up at runtime with respect to the module that +;; was current when the lambda was bound, at runtime. The variable will +;; be resolved when it is first used. +(define (ghil-var-is-bound? env sym) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (cons (module-name (current-module)) sym))) + (assoc-ref table key))) + ((<ghil-env> parent table variables) + (and (not (assq-ref table sym)) + (loop parent)))))) + +(define (ghil-var-for-ref! env sym) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref table key) + (let ((var (make-ghil-var (car key) (cdr key) 'toplevel))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + ((<ghil-env> parent table variables) + (cond + ((assq-ref table sym) + => (lambda (var) + (or (eq? e env) + (force-heap-allocation! var)) + var)) + (else + (loop parent))))))) + +(define (ghil-var-for-set! env sym) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref table key) + (let ((var (make-ghil-var (car key) (cdr key) 'toplevel))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + ((<ghil-env> parent table variables) + (cond + ((assq-ref table sym) + => (lambda (var) + (force-heap-allocation! var) + var)) + (else + (loop parent))))))) + +(define (ghil-var-at-module! env modname sym interface?) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (list modname sym interface?))) + (or (assoc-ref table key) + (let ((var (make-ghil-var modname sym + (if interface? 'public 'private)))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + ((<ghil-env> parent table variables) + (loop parent))))) + +(define (ghil-var-define! toplevel sym) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref (ghil-toplevel-env-table toplevel) key) + (let ((var (make-ghil-var (car key) (cdr key) 'toplevel))) + (apush! key var (ghil-toplevel-env-table toplevel)) + 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)) + + +;;; +;;; 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)))) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm new file mode 100644 index 000000000..75fca0621 --- /dev/null +++ b/module/system/il/glil.scm @@ -0,0 +1,222 @@ +;;; 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-mv-bind> make-glil-mv-bind glil-mv-bind? + glil-mv-bind-vars glil-mv-bind-rest + + <glil-unbind> make-glil-unbind glil-unbind? + + <glil-source> make-glil-source glil-source? + glil-source-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-toplevel> make-glil-toplevel glil-toplevel? + glil-toplevel-op glil-toplevel-name + + <glil-module> make-glil-module glil-module? + glil-module-op glil-module-mod glil-module-name glil-module-public? + + <glil-label> make-glil-label glil-label? + glil-label-label + + <glil-branch> make-glil-branch glil-branch? + glil-branch-inst glil-branch-label + + <glil-call> make-glil-call glil-call? + glil-call-inst glil-call-nargs + + <glil-mv-call> make-glil-mv-call glil-mv-call? + glil-mv-call-nargs glil-mv-call-ra)) + +(define-record (<glil-vars> nargs nrest nlocs nexts)) + +(define-type <glil> + (| + ;; Meta operations + (<glil-asm> vars meta body) + (<glil-bind> vars) + (<glil-mv-bind> vars rest) + (<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-toplevel> op name) + (<glil-module> op mod name public?) + ;; Controls + (<glil-label> label) + (<glil-branch> inst label) + (<glil-call> inst nargs) + (<glil-mv-call> nargs ra))) + + +;;; +;;; 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 'goto/args) n) +;;; (make-instn (car x) n)) +;;; ;; (INST) +;;; ((inst) +;;; (if (instruction? inst) +;;; (make-inst inst) +;;; (error "Unknown instruction:" inst))))) + + +;;; +;;; 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-toplevel> op name) + `(,(symbol-append 'toplevel- op) ,name)) + ((<glil-module> op mod name public?) + `(,(symbol-append (if public? 'public 'private) '- op) ,mod ,name)) + ;; controls + ((<glil-label> label) label) + ((<glil-branch> inst label) `(,inst ,label)) + ((<glil-call> inst nargs) `(,inst ,nargs)))) + + +;;; +;;; 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))) diff --git a/module/system/il/inline.scm b/module/system/il/inline.scm new file mode 100644 index 000000000..dd931f633 --- /dev/null +++ b/module/system/il/inline.scm @@ -0,0 +1,200 @@ +;;; 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 (try-inline-with-env env loc exp) + (let ((sym (car exp))) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((mod (current-module))) + (and (not (assoc-ref table (cons (module-name mod) sym))) + (module-bound? mod sym) + (try-inline (module-ref mod sym) (cdr exp))))) + ((<ghil-env> 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 cons* + (x) x + (x y) (cons x y) + (x y . rest) (cons x (cons* y . rest))) diff --git a/module/system/repl/.cvsignore b/module/system/repl/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/system/repl/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/system/repl/Makefile.am b/module/system/repl/Makefile.am new file mode 100644 index 000000000..7a5dbc6d9 --- /dev/null +++ b/module/system/repl/Makefile.am @@ -0,0 +1,4 @@ +NOCOMP_SOURCES = describe.scm +SOURCES = repl.scm common.scm command.scm +modpath = system/repl +include $(top_srcdir)/guilec.mk diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm new file mode 100644 index 000000000..ca5346d90 --- /dev/null +++ b/module/system/repl/command.scm @@ -0,0 +1,459 @@ +;;; 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)) + + +;;; +;;; 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)))))))) + + +;;; +;;; 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)) + + +;;; +;;; 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))) + + +;;; +;;; Language commands +;;; + +(define (language repl name) + "language LANGUAGE +Change languages." + (set! (repl-language repl) (lookup-language name)) + (repl-welcome repl)) + + +;;; +;;; 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)))) + + +;;; +;;; 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)) + + +;;; +;;; 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")) + + +;;; +;;; 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")) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm new file mode 100644 index 000000000..608c38577 --- /dev/null +++ b/module/system/repl/common.scm @@ -0,0 +1,101 @@ +;;; 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)) + + +;;; +;;; Repl type +;;; + +(define-record (<repl> vm language options tm-stats gc-stats vm-stats)) + +(define repl-default-options + '((trace . #f) + (interp . #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 (and eval + (or (not (language-translator (repl-language repl))) + (assq-ref (repl-options repl) 'interp))) + (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))) + + +;;; +;;; 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)) diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm new file mode 100644 index 000000000..0563def90 --- /dev/null +++ b/module/system/repl/describe.scm @@ -0,0 +1,361 @@ +;;; 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)))) + + +;;; +;;; 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)))) + + +;;; +;;; 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")) + + +;;; +;;; 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")) + + +;;; +;;; Strings +;;; + +(define-method (display-type (obj <string>)) + (if (read-only-string? 'obj) + (display "a read-only string") + (display-class <string> "a string")) + (display ".\n")) + + +;;; +;;; 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)))) + + +;;; +;;; 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))) + + +;;; +;;; 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)))) + + +;;; +;;; 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))) + + +;;; +;;; 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)))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm new file mode 100644 index 000000000..8fd5be2ee --- /dev/null +++ b/module/system/repl/repl.scm @@ -0,0 +1,147 @@ +;;; 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) + (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)) + (status #f)) + (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) + (newline) + (set! status '())) + (else + (call-with-backtrace + (lambda () + (catch 'quit + (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)))) + (lambda (k . args) + (set! status args))))))) + (or status + (begin + (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) ch) + ((char-whitespace? ch) (read-char) (next-char wait)) + (else ch))) + #f)) diff --git a/module/system/vm/.cvsignore b/module/system/vm/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/system/vm/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/system/vm/Makefile.am b/module/system/vm/Makefile.am new file mode 100644 index 000000000..43807c086 --- /dev/null +++ b/module/system/vm/Makefile.am @@ -0,0 +1,5 @@ +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 diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm new file mode 100644 index 000000000..bbbee35cb --- /dev/null +++ b/module/system/vm/assemble.scm @@ -0,0 +1,384 @@ +;;; 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)) + + +;;; +;;; Types +;;; + +(define-record (<vm-asm> venv glil body)) +(define-record (<venv> parent nexts closure?)) +;; key is either a symbol or the list (MODNAME SYM PUBLIC?) +(define-record (<vlink-now> key)) +(define-record (<vlink-later> key)) +(define-record (<vdefine> name)) +(define-record (<bytespec> vars bytes meta objs closure?)) + + +;;; +;;; 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))) + + +;;; +;;; Stage 2: Bytecode generation +;;; + +(define-macro (push x loc) + `(set! ,loc (cons ,x ,loc))) + +;; this is to avoid glil-const's desire to put constants in the object +;; array -- instead we explicitly want them in the code, because meta +;; info is infrequently used. to load it up always would make garbage, +;; needlessly. so hide it behind a lambda. +(define (make-meta bindings sources tail) + (if (and (null? bindings) (null? sources) (null? tail)) + #f + (let ((stack '())) + (define (push-code! code) + (push (code->bytes code) stack)) + (dump-object! push-code! `(,bindings ,sources ,@tail)) + (push-code! '(return)) + (make-bytespec #:vars (make-glil-vars 0 0 0 0) + #:bytes (stack->bytes (reverse! stack) '()) + #:meta #f #:objs #f #:closure? #f)))) + +(define (byte-length x) + (cond ((u8vector? x) (u8vector-length x)) + ((>= (instruction-length (car x)) 0) + ;; one byte for the instruction itself + (1+ (instruction-length (car x)))) + (else (error "variable-length instruction?" x)))) + +(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) + (push (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) + (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-mv-bind> (binds vars) rest) + (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)) + (push-code! `(truncate-values ,(length binds) ,(if rest 1 0))))) + + ((<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-toplevel> op name) + (case op + ((ref set) + (cond + (toplevel + (push-object! (make-vlink-now #:key name)) + (push-code! (case op + ((ref) '(variable-ref)) + ((set) '(variable-set))))) + (else + (let* ((var (make-vlink-later #:key 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 #:name name)) + (push-code! '(variable-set))) + (else + (error "unknown toplevel var kind" op name)))) + + ((<glil-module> op mod name public?) + (let ((key (list mod name public?))) + (case op + ((ref set) + (cond + (toplevel + (push-object! (make-vlink-now #:key key)) + (push-code! (case op + ((ref) '(variable-ref)) + ((set) '(variable-set))))) + (else + (let* ((var (make-vlink-later #:key key)) + (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)))))))) + (else + (error "unknown module var kind" op key))))) + + ((<glil-label> label) + (set! label-alist (assq-set! label-alist label (current-address)))) + + ((<glil-branch> inst label) + (push (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))) + + ((<glil-mv-call> nargs ra) + (push (list 'mv-call nargs ra) stack)))) + + ;; + ;; 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 (make-meta (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 (check-length len u8v) + (or (= len (u8vector-length u8v)) + (error "the badness!" len u8v)) + u8v) + +(define (stack->bytes stack label-alist) + (let loop ((result '()) (stack stack) (addr 0)) + (if (null? stack) + (check-length + addr + (list->u8vector + (append-map u8vector->list (reverse! result)))) + (let ((elt (car stack))) + (cond + ((u8vector? elt) + (loop (cons elt result) + (cdr stack) + (+ addr (byte-length elt)))) + ((symbol? (car (last-pair elt))) + ;; not yet code because labels needed to be resolved + (let* ((head (list-head elt (1- (length elt)))) + (label-addr (assq-ref label-alist (car (last-pair elt)))) + (offset (- label-addr (+ addr (byte-length elt)))) + (n (if (< offset 0) (+ offset 65536) offset))) + (loop (cons (code->bytes + (append head (list (quotient n 256) (modulo n 256)))) + result) + (cdr stack) + (+ addr (byte-length elt))))) + (else (error "bad code" elt))))))) + + +;;; +;;; 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 16) (< nlocs 128) (< nexts 16)) + ;; 16-bit representation + (let ((x (logior + (ash nargs 12) (ash nrest 11) (ash nlocs 4) nexts))) + (push-code! `(make-int16 ,(ash x -8) ,(logand x (1- (ash 1 8))))))) + (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> key) + (dump! key)) + ((<vlink-now> key) + (dump! key) + (push-code! '(link-now))) + ((<vdefine> name) + (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))))) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm new file mode 100644 index 000000000..914044102 --- /dev/null +++ b/module/system/vm/conv.scm @@ -0,0 +1,194 @@ +;;; 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)))) + + +;;; +;;; 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)) + (values #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)))))) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm new file mode 100644 index 000000000..b37d5095e --- /dev/null +++ b/module/system/vm/debug.scm @@ -0,0 +1,62 @@ +;;; 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)) + + +;;; +;;; 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)))))) + + +;;; +;;; Backtrace +;;; + +(define (vm-backtrace vm) + (print-frame-chain-as-backtrace + (reverse (vm-last-frame-chain vm)))) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm new file mode 100644 index 000000000..279260640 --- /dev/null +++ b/module/system/vm/disasm.scm @@ -0,0 +1,209 @@ +;;; 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 prog (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 '())) + (define (lp addr code) + (pmatch code + (#f (newline)) + ((load-program ,x) + (let ((sym (gensym ""))) + (set! programs (acons sym x programs)) + (print-info addr (format #f "(load-program #~A)" sym) #f))) + (else + (print-info addr (list->info code) + (original-value addr code objs)))) + (if code (call-with-values decode lp))) + (call-with-values decode lp) + (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-bindings prog bindings) + (let* ((nargs (arity:nargs (program-arity prog))) + (args (if (zero? nargs) '() (cdar bindings))) + (nonargs (if (zero? nargs) bindings (cdr bindings)))) + (unless (null? args) + (display "Arguments:\n\n") + (for-each (lambda (bind n) + (print-info n + (format #f "~a[~a]: ~a" + (if (cadr bind) 'external 'local) + (caddr bind) (car bind)) + #f)) + args + (iota nargs)) + (newline)) + (unless (null? nonargs) + (display "Bindings:\n\n") + (for-each (lambda (start binds end) + (for-each (lambda (bind) + (print-info (format #f "~a-~a" start end) + (format #f "~a[~a]: ~a" + (if (cadr bind) 'external 'local) + (caddr bind) (car bind)) + #f)) + binds)) + (map car (filter cdr nonargs)) + (map cdr (filter cdr nonargs)) + (map car (filter (lambda (x) (not (cdr x))) nonargs))) + (newline)))) + +(define (disassemble-meta program meta) + (let ((bindings (car meta)) + (sources (cadr meta)) + (props (cddr meta))) + (unless (null? bindings) + (disassemble-bindings program bindings)) + (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)) + ((mv-call) + (let ((offset (+ (* (caddr code) 256) (cadddr code)))) + (format #f "MV -> ~A" (+ addr offset 4)))) + (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) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm new file mode 100644 index 000000000..70b82f872 --- /dev/null +++ b/module/system/vm/frame.scm @@ -0,0 +1,210 @@ +;;; 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) 6) + (= (uniform-vector-ref code 5) + (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))))) + + +;;; +;;; 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) 4) + (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 (frame-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 (frame-program-name frame) + (let ((prog (frame-program frame)) + (link (frame-dynamic-link frame))) + (or (program-name prog) + (object-property prog 'name) + (and (heap-frame? link) (frame-address link) + (frame-object-name link (1- (frame-address link)) prog)) + (hash-fold (lambda (s v d) (if (and (variable-bound? v) + (eq? prog (variable-ref v))) + s d)) + prog (module-obarray (current-module)))))) + + +;;; +;;; 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))) + +;; FIXME handle #f program-bindings return +(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))) diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm new file mode 100644 index 000000000..c820e9952 --- /dev/null +++ b/module/system/vm/instruction.scm @@ -0,0 +1,28 @@ +;;; 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")) diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm new file mode 100644 index 000000000..70fd18adf --- /dev/null +++ b/module/system/vm/objcode.scm @@ -0,0 +1,26 @@ +;;; 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")) diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm new file mode 100644 index 000000000..2c17fc7a6 --- /dev/null +++ b/module/system/vm/profile.scm @@ -0,0 +1,65 @@ +;;; 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)))))))) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm new file mode 100644 index 000000000..f31d5bf31 --- /dev/null +++ b/module/system/vm/program.scm @@ -0,0 +1,98 @@ +;;; 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-name + + program-arity program-external-set! program-meta + program-bytecode program? program-objects + program-module 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 (curry1 proc) + (lambda (x) (proc (x)))) + +(define (program-bindings prog) + (cond ((program-meta prog) => (curry1 car)) + (else #f))) + +(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) => (curry1 cadr)) + (else '()))) + +(define (program-properties prog) + (or (and=> (program-meta prog) (curry1 cddr)) + '())) + +(define (program-property prog prop) + (assq-ref (program-properties proc) prop)) + +(define (program-documentation prog) + (assq-ref (program-properties prog) 'documentation)) + +(define (program-name prog) + (assq-ref (program-properties prog) 'name)) + +(define (program-bindings-as-lambda-list prog) + (let ((bindings (program-bindings prog)) + (nargs (arity:nargs (program-arity prog))) + (rest? (not (zero? (arity:nrest (program-arity prog)))))) + (if (or (null? bindings) (not bindings)) + (if rest? (cons (1- nargs) 1) (list nargs)) + (let ((arg-names (map binding:name (cdar bindings)))) + (if rest? + (apply cons* arg-names) + arg-names))))) + +(define (write-program prog port) + (format port "#<program ~a ~a>" + (or (program-name prog) + (let ((s (program-sources prog))) + (and (not (null? s)) (cdar s))) + (number->string (object-address prog) 16)) + (program-bindings-as-lambda-list prog))) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm new file mode 100644 index 000000000..00f013c9d --- /dev/null +++ b/module/system/vm/trace.scm @@ -0,0 +1,78 @@ +;;; 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))))) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm new file mode 100644 index 000000000..e4f5e98a3 --- /dev/null +++ b/module/system/vm/vm.scm @@ -0,0 +1,62 @@ +;;; 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 *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))) diff --git a/oop/goops.scm b/oop/goops.scm index c8f1f1837..3af60f937 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -79,6 +79,8 @@ :replace (<class> <operator-class> <entity-class> <entity>) :no-backtrace) +(define *goops-module* (current-module)) + ;; First initialize the builtin part of GOOPS (%init-goops-builtins) @@ -1173,14 +1175,17 @@ (vector-set! methods index m) m))))) +;; eval tricks are apparently to make the accessors as fast as possible +;; for the evaluator. when goops gets vm-aware, this will be different. + (define (make-bound-check-get index) - (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment))) + (eval `(lambda (o) (@assert-bound-ref o ,index)) *goops-module*)) (define (make-get index) - (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment))) + (eval `(lambda (o) (@slot-ref o ,index)) *goops-module*)) (define (make-set index) - (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment))) + (eval `(lambda (o v) (@slot-set! o ,index v)) *goops-module*)) (define bound-check-get (standard-accessor-method make-bound-check-get bound-check-get-methods)) diff --git a/pre-inst-guile-env.in b/pre-inst-guile-env.in index 5bf1e136a..f9dd60179 100644 --- a/pre-inst-guile-env.in +++ b/pre-inst-guile-env.in @@ -31,7 +31,7 @@ # 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@" @@ -47,9 +47,14 @@ top_builddir="@top_builddir_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. @@ -61,6 +66,11 @@ else fi export GUILE_LOAD_PATH +# Don't look in installed dirs for guile modules +if ( env | grep -v -q -E '^GUILE_SYSTEM_PATH=' ); then + export GUILE_SYSTEM_PATH= +fi + # handle LTDL_LIBRARY_PATH (no clobber) ltdl_prefix="" dyld_prefix="" diff --git a/pre-inst-guile.in b/pre-inst-guile.in index d210fdebc..5adbabea2 100644 --- a/pre-inst-guile.in +++ b/pre-inst-guile.in @@ -19,13 +19,6 @@ # 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] @@ -42,56 +35,15 @@ # 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 diff --git a/scripts/Makefile.am b/scripts/Makefile.am index baf8ff46d..ca96da78d 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -25,6 +25,8 @@ AUTOMAKE_OPTIONS = gnu scripts_sources = \ PROGRAM \ autofrisk \ + compile \ + disassemble \ display-commentary \ doc-snarf \ frisk \ diff --git a/scripts/compile b/scripts/compile new file mode 100755 index 000000000..ebe810a20 --- /dev/null +++ b/scripts/compile @@ -0,0 +1,90 @@ +#!/bin/sh +# -*- scheme -*- +exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@" +!# +;;; Compile --- Command-line Guile Scheme compiler + +;; Copyright 2005,2008 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Author: Andy Wingo <wingo@pobox.com> + +;;; Commentary: + +;; Usage: compile [ARGS] +;; +;; PROGRAM does something. +;; +;; TODO: Write it! + +;;; Code: + +(define-module (scripts compile) + #:use-module (system base compile) + #:use-module (ice-9 getopt-long) + #:export (compile)) + +(define %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)))) + +(define (compile args) + (let* ((options (getopt-long args %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: compile [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 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)))))) diff --git a/scripts/disassemble b/scripts/disassemble new file mode 100755 index 000000000..be55cf338 --- /dev/null +++ b/scripts/disassemble @@ -0,0 +1,41 @@ +#!/bin/sh +# -*- scheme -*- +exec ${GUILE-guile} -e '(@ (scripts disassemble) disassemble)' -s $0 "$@" +!# +;;; Disassemble --- Disassemble .go files into something human-readable + +;; Copyright 2005,2008 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Author: Andy Wingo <wingo@pobox.com> + +;;; Commentary: + +;; Usage: disassemble [ARGS] + +;;; Code: + +(define-module (scripts disassemble) + #:use-module (system vm objcode) + #:use-module (system vm disasm) + #:export (disassemble)) + +(define (disassemble args) + (for-each (lambda (file) + (disassemble-objcode (load-objcode file))) + (cdr args))) diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index a61850af2..c0cbb92cd 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -25,18 +25,19 @@ ;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match ;; libguile/filesys.c of course) -(or (equal? (procedure-source stat:dev) - '(lambda (f) (vector-ref f 0))) - (error "oops, unexpected stat:dev definition")) (define (stat:dev! st dev) (vector-set! st 0 dev)) - -(or (equal? (procedure-source stat:ino) - '(lambda (f) (vector-ref f 1))) - (error "oops, unexpected stat:ino definition")) (define (stat:ino! st ino) (vector-set! st 1 ino)) +(let* ((s (stat "/")) + (i (stat:ino s)) + (d (stat:dev s))) + (stat:ino! s (1+ i)) + (stat:dev! s (1+ d)) + (if (not (and (= (stat:ino s) (1+ i)) + (= (stat:dev s) (1+ d)))) + (error "unexpected definitions of stat:dev and stat:ino"))) ;; ;; visited?-proc diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test index 8fa78e9c1..1357345b2 100644 --- a/test-suite/tests/r5rs_pitfall.test +++ b/test-suite/tests/r5rs_pitfall.test @@ -27,15 +27,15 @@ (syntax-rules () ((_ test-id value expression) (run-test test-id #t (lambda () - (false-if-exception - (equal? expression value))))))) + (false-if-exception + (equal? expression value))))))) (define-syntax should-be-but-isnt (syntax-rules () ((_ test-id value expression) (run-test test-id #f (lambda () - (false-if-exception - (equal? expression value))))))) + (false-if-exception + (equal? expression value))))))) (define call/cc call-with-current-continuation) @@ -65,7 +65,7 @@ (should-be 1.2 #t (letrec ((x (call/cc list)) (y (call/cc list))) (cond ((procedure? x) (x (pair? y))) - ((procedure? y) (y (pair? x)))) + ((procedure? y) (y (pair? x)))) (let ((x (car x)) (y (car y))) (and (call/cc x) (call/cc y) (call/cc x))))) @@ -75,11 +75,11 @@ ;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU (should-be 1.3 #t (letrec ((x (call-with-current-continuation - (lambda (c) - (list #T c))))) + (lambda (c) + (list #T c))))) (if (car x) - ((cadr x) (list #F (lambda () x))) - (eq? x ((cadr x)))))) + ((cadr x) (list #F (lambda () x))) + (eq? x ((cadr x)))))) ;; Section 2: Proper call/cc and procedure application @@ -300,12 +300,12 @@ (define res1 #f) (define res2 #f) (set! res1 (map (lambda (x) - (if (= x 0) - (call/cc (lambda (k) (set! cont k) 0)) - 0)) - '(1 0 2))) + (if (= x 0) + (call/cc (lambda (k) (set! cont k) 0)) + 0)) + '(1 0 2))) (if (not executed-k) - (begin (set! executed-k #t) - (set! res2 res1) - (cont 1))) + (begin (set! executed-k #t) + (set! res2 res1) + (cont 1))) res2)) diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am new file mode 100644 index 000000000..6ff48b5de --- /dev/null +++ b/testsuite/Makefile.am @@ -0,0 +1,33 @@ +# 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-call-cc.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-quasiquote.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) diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm new file mode 100644 index 000000000..9f07d0561 --- /dev/null +++ b/testsuite/run-vm-tests.scm @@ -0,0 +1,97 @@ +;;; 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)) + + +(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)))) + + +(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") + + +;; 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))))) + diff --git a/testsuite/t-basic-contructs.scm b/testsuite/t-basic-contructs.scm new file mode 100644 index 000000000..53ee81dcd --- /dev/null +++ b/testsuite/t-basic-contructs.scm @@ -0,0 +1,16 @@ +;;; 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)))) + diff --git a/testsuite/t-call-cc.scm b/testsuite/t-call-cc.scm new file mode 100644 index 000000000..05e4de98c --- /dev/null +++ b/testsuite/t-call-cc.scm @@ -0,0 +1,16 @@ +(let ((set-counter2 #f)) + (define (get-counter2) + (call/cc + (lambda (k) + (set! set-counter2 k) + 1))) + (define (loop counter1) + (let ((counter2 (get-counter2))) + (set! counter1 (1+ counter1)) + (cond ((not (= counter1 counter2)) + (error "bad call/cc behaviour" counter1 counter2)) + ((> counter1 10) + #t) + (else + (set-counter2 (1+ counter2)))))) + (loop 0)) diff --git a/testsuite/t-catch.scm b/testsuite/t-catch.scm new file mode 100644 index 000000000..9cc3e0e14 --- /dev/null +++ b/testsuite/t-catch.scm @@ -0,0 +1,10 @@ +;; 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))))) + diff --git a/testsuite/t-closure.scm b/testsuite/t-closure.scm new file mode 100644 index 000000000..3d791979e --- /dev/null +++ b/testsuite/t-closure.scm @@ -0,0 +1,8 @@ +(define func + (let ((x 2)) + (lambda () + (let ((x++ (+ 1 x))) + (set! x x++) + x++)))) + +(list (func) (func) (func)) diff --git a/testsuite/t-closure2.scm b/testsuite/t-closure2.scm new file mode 100644 index 000000000..fd1df34fd --- /dev/null +++ b/testsuite/t-closure2.scm @@ -0,0 +1,10 @@ + +(define (uid) + (let* ((x 2) + (do-uid (lambda () + (let ((x++ (+ 1 x))) + (set! x x++) + x++)))) + (do-uid))) + +(list (uid) (uid) (uid)) diff --git a/testsuite/t-closure3.scm b/testsuite/t-closure3.scm new file mode 100644 index 000000000..2295a511a --- /dev/null +++ b/testsuite/t-closure3.scm @@ -0,0 +1,7 @@ +(define (stuff) + (let* ((x 2) + (chbouib (lambda (z) + (+ 7 z x)))) + (chbouib 77))) + +(stuff) diff --git a/testsuite/t-do-loop.scm b/testsuite/t-do-loop.scm new file mode 100644 index 000000000..6455bcdb2 --- /dev/null +++ b/testsuite/t-do-loop.scm @@ -0,0 +1,5 @@ +(let ((n+ 0)) + (do ((n- 5 (1- n-)) + (n+ n+ (1+ n+))) + ((= n- 0)) + (format #f "n- = ~a~%" n-))) diff --git a/testsuite/t-global-bindings.scm b/testsuite/t-global-bindings.scm new file mode 100644 index 000000000..c8ae3692c --- /dev/null +++ b/testsuite/t-global-bindings.scm @@ -0,0 +1,13 @@ +;; 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))) + diff --git a/testsuite/t-macros.scm b/testsuite/t-macros.scm new file mode 100644 index 000000000..bb44b46b7 --- /dev/null +++ b/testsuite/t-macros.scm @@ -0,0 +1,4 @@ +;; Are built-in macros well-expanded at compilation-time? + +(false-if-exception (+ 2 2)) +(read-options) diff --git a/testsuite/t-macros2.scm b/testsuite/t-macros2.scm new file mode 100644 index 000000000..4cc258278 --- /dev/null +++ b/testsuite/t-macros2.scm @@ -0,0 +1,17 @@ +;; 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)) + + +(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 + diff --git a/testsuite/t-map.scm b/testsuite/t-map.scm new file mode 100644 index 000000000..76bf1730f --- /dev/null +++ b/testsuite/t-map.scm @@ -0,0 +1,10 @@ +; 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))) diff --git a/testsuite/t-match.scm b/testsuite/t-match.scm new file mode 100644 index 000000000..4b85f30d3 --- /dev/null +++ b/testsuite/t-match.scm @@ -0,0 +1,26 @@ +;;; 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))) + + +;(format #t "go!~%") +(and (matches? (%make-stuff 12)) + (matches? (%make-stuff 7)) + (matches? "hello") +; (matches? 'blurps) + (not (matches? 66))) diff --git a/testsuite/t-mutual-toplevel-defines.scm b/testsuite/t-mutual-toplevel-defines.scm new file mode 100644 index 000000000..795c74423 --- /dev/null +++ b/testsuite/t-mutual-toplevel-defines.scm @@ -0,0 +1,8 @@ +(define (even? x) + (or (zero? x) + (not (odd? (1- x))))) + +(define (odd? x) + (not (even? (1- x)))) + +(even? 20) diff --git a/testsuite/t-or.scm b/testsuite/t-or.scm new file mode 100644 index 000000000..0c581e9c7 --- /dev/null +++ b/testsuite/t-or.scm @@ -0,0 +1,29 @@ +;; 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) + ;; not in tail position, value discarded + (begin (or 'what (error "two")) 'two) + ;; 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)))) diff --git a/testsuite/t-proc-with-setter.scm b/testsuite/t-proc-with-setter.scm new file mode 100644 index 000000000..f6ffe15b0 --- /dev/null +++ b/testsuite/t-proc-with-setter.scm @@ -0,0 +1,20 @@ +(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)))) diff --git a/testsuite/t-quasiquote.scm b/testsuite/t-quasiquote.scm new file mode 100644 index 000000000..6c482b8d8 --- /dev/null +++ b/testsuite/t-quasiquote.scm @@ -0,0 +1,9 @@ +(list + `() + `foo + `(foo) + `(foo bar) + `(1 2) + (let ((x 1)) `,x) + (let ((x 1)) `(,x)) + (let ((x 1)) ``(,x))) diff --git a/testsuite/t-records.scm b/testsuite/t-records.scm new file mode 100644 index 000000000..0cb320da3 --- /dev/null +++ b/testsuite/t-records.scm @@ -0,0 +1,15 @@ +;;; SRFI-9 Records. +;;; + +(use-modules (srfi srfi-9)) + +(define-record-type <stuff> + (%make-stuff chbouib) + stuff? + (chbouib stuff:chbouib stuff:set-chbouib!)) + + +(and (stuff? (%make-stuff 12)) + (= 7 (stuff:chbouib (%make-stuff 7))) + (not (stuff? 12)) + (not (false-if-exception (%make-stuff)))) diff --git a/testsuite/t-values.scm b/testsuite/t-values.scm new file mode 100644 index 000000000..e741ae423 --- /dev/null +++ b/testsuite/t-values.scm @@ -0,0 +1,8 @@ +(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))) + diff --git a/testsuite/the-bug.txt b/testsuite/the-bug.txt new file mode 100644 index 000000000..95683f445 --- /dev/null +++ b/testsuite/the-bug.txt @@ -0,0 +1,95 @@ +-*- 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 + |