benchmark-guile
check-guile
check-guile.log
-compile
+build-aux/compile
confdefs.h
config.build-subdirs
config.cache
guile-config/guile-config
guile-readline/guile-readline-config.h
guile-readline/guile-readline-config.h.in
+*.go
TAGS
guile-1.8.pc
+gdb-pre-inst-guile
libguile/stack-limit-calibration.scm
cscope.out
cscope.files
#
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 libguile guile-config guile-readline emacs \
+ scripts srfi doc examples test-suite benchmark-suite lang am \
+ module testsuite
bin_SCRIPTS = guile-tools
--- /dev/null
+Guile-VM NEWS
+
+
+Guile-VM is a bytecode compiler and virtual machine for Guile.
+
+
+guile-vm 0.7 -- 2008-05-20
+==========================
+
+* Initial release with NEWS.
+
+* Revived from Keisuke Nishida's Guile-VM project from 2000-2001, with
+ the help of Ludovic Courtès.
+
+* Meta-level changes
+** Updated to compile with Guile 1.8.
+** Documentation updated, including documentation on the instructions.
+** Added benchmarking and a test harness.
+
+* Changes to the inventory
+** Renamed the library from libguilevm to libguile-vm.
+** Added new executable script, guile-disasm.
+
+* New features
+** Add support for compiling macros, both defmacros and syncase macros.
+Primitive macros produced with the procedure->macro family of procedures
+are not supported, however.
+** Improvements to the REPL
+Multiple values support, readline integration, ice-9 history integration
+** Add support for eval-case
+The compiler recognizes compile-toplevel in addition to load-toplevel
+** Completely self-compiling
+Almost, anyway: not (system repl describe), because it uses GOOPS
+
+* Internal cleanups
+** Internal objects are now based on Guile records.
+** Guile-VM's code doesn't use the dot-syntax any more.
+** Changed (ice-9 match) for Kiselyov's pmatch.scm
+** New instructions: define, link-later, link-now, late-variable-{ref,set}
+** Object code now represented as u8vectors instead of strings.
+** Remove local import of an old version of slib
+
+* Bugfixes
+** The `optimize' procedure is coming out of bitrot
+** The Scheme compiler is now more strict about placement of internal
+ defines
+** set! is now compiled differently from define
+** Module-level variables are now bound at first use instead of in the
+ program prolog
+** Bugfix to load-program (stack misinterpretation)
+
+
+Copyright (C) 2008 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification, are
+permitted in any medium without royalty provided the copyright notice
+and this notice are preserved.
--- /dev/null
+This is an attempt to revive the Guile-VM project by Keisuke Nishida
+written back in the years 2000 and 2001. Below are a few pointers to
+relevant threads on Guile's development mailing list.
+
+Enjoy!
+
+Ludovic Courtès <ludovic.courtes@laas.fr>, Apr. 2005.
+
+
+Pointers
+--------
+
+Status of the last release, 0.5
+ http://lists.gnu.org/archive/html/guile-devel/2001-04/msg00266.html
+
+The very first release, 0.0
+ http://sources.redhat.com/ml/guile/2000-07/msg00418.html
+
+Simple benchmark
+ http://sources.redhat.com/ml/guile/2000-07/msg00425.html
+
+Performance, portability, GNU Lightning
+ http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00132.html
+
+Playing with GNU Lightning
+ http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00185.html
+
+On things left to be done
+ http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00146.html
+
+
+---8<--- Original README below. -----------------------------------------
+
+Installation
+------------
+
+1. Install the latest Guile from CVS.
+
+2. Install Guile VM:
+
+ % configure
+ % make install
+ % ln -s module/{guile,system,language} /usr/local/share/guile/
+
+3. Add the following lines to your ~/.guile:
+
+ (use-modules (system vm core)
+
+ (cond ((string=? (car (command-line)) "guile-vm")
+ (use-modules (system repl repl))
+ (start-repl 'scheme)
+ (quit)))
+
+Example Session
+---------------
+
+ % guile-vm
+ Guile Scheme interpreter 0.5 on Guile 1.4.1
+ Copyright (C) 2001 Free Software Foundation, Inc.
+
+ Enter `,help' for help.
+ scheme@guile-user> (+ 1 2)
+ 3
+ scheme@guile-user> ,c -c (+ 1 2) ;; Compile into GLIL
+ (@asm (0 1 0 0)
+ (module-ref #f +)
+ (const 1)
+ (const 2)
+ (tail-call 2))
+ scheme@guile-user> ,c (+ 1 2) ;; Compile into object code
+ Disassembly of #<objcode 403c5fb0>:
+
+ nlocs = 0 nexts = 0
+
+ 0 link "+" ;; (+ . ???)
+ 3 variable-ref
+ 4 make-int8:1 ;; 1
+ 5 make-int8 2 ;; 2
+ 7 tail-call 2
+
+ scheme@guile-user> (define (add x y) (+ x y))
+ scheme@guile-user> (add 1 2)
+ 3
+ scheme@guile-user> ,x add ;; Disassemble
+ Disassembly of #<program add>:
+
+ nargs = 2 nrest = 0 nlocs = 0 nexts = 0
+
+ Bytecode:
+
+ 0 object-ref 0 ;; (+ . #<primitive-procedure +>)
+ 2 variable-ref
+ 3 local-ref 0
+ 5 local-ref 1
+ 7 tail-call 2
+
+ Objects:
+
+ 0 (+ . #<primitive-procedure +>)
+
+ scheme@guile-user>
+
+Compile Modules
+---------------
+
+Use `guilec' to compile your modules:
+
+ % cat fib.scm
+ (define-module (fib) :export (fib))
+ (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
+
+ % guilec fib.scm
+ Wrote fib.go
+ % guile
+ guile> (use-modules (fib))
+ guile> (fib 8)
+ 34
--- /dev/null
+Guile VM was inspired by QScheme, librep, and Objective Caml.
AUTOMAKE_OPTIONS = gnu
-am_frags = pre-inst-guile maintainer-dirs
+am_frags = pre-inst-guile maintainer-dirs guilec
EXTRA_DIST = $(am_frags) ChangeLog-2008
--- /dev/null
+# -*- makefile -*-
+GOBJECTS = $(SOURCES:%.scm=%.go)
+
+moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
+nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) $(GOBJECTS)
+EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
+
+CLEANFILES = $(GOBJECTS)
+
+SUFFIXES = .scm .go
+.scm.go:
+ $(MKDIR_P) `dirname $@`
+ $(top_builddir)/pre-inst-guile-env $(top_builddir)/guile-tools compile -o "$@" "$<"
--- /dev/null
+;; -*- Scheme -*-
+;;
+;; A library of dumb functions that may be used to benchmark Guile-VM.
+
+
+;; The comments are from Ludovic, a while ago. The speedups now are much
+;; more significant (all over 2x, sometimes 8x).
+
+(define (fibo x)
+ (if (or (= x 1) (= x 2))
+ 1
+ (+ (fibo (- x 1))
+ (fibo (- x 2)))))
+
+(define (g-c-d x y)
+ (if (= x y)
+ x
+ (if (< x y)
+ (g-c-d x (- y x))
+ (g-c-d (- x y) y))))
+
+(define (loop n)
+ ;; This one shows that procedure calls are no faster than within the
+ ;; interpreter: the VM yields no performance improvement.
+ (if (= 0 n)
+ 0
+ (loop (1- n))))
+
+;; Disassembly of `loop'
+;;
+;; Disassembly of #<objcode b79bdf28>:
+
+;; nlocs = 0 nexts = 0
+
+;; 0 (make-int8 64) ;; 64
+;; 2 (load-symbol "guile-user") ;; guile-user
+;; 14 (list 0 1) ;; 1 element
+;; 17 (load-symbol "loop") ;; loop
+;; 23 (link-later)
+;; 24 (vector 0 1) ;; 1 element
+;; 27 (make-int8 0) ;; 0
+;; 29 (load-symbol "n") ;; n
+;; 32 (make-false) ;; #f
+;; 33 (make-int8 0) ;; 0
+;; 35 (list 0 3) ;; 3 elements
+;; 38 (list 0 2) ;; 2 elements
+;; 41 (list 0 1) ;; 1 element
+;; 44 (make-int8 5) ;; 5
+;; 46 (make-false) ;; #f
+;; 47 (cons)
+;; 48 (make-int8 18) ;; 18
+;; 50 (make-false) ;; #f
+;; 51 (cons)
+;; 52 (make-int8 20) ;; 20
+;; 54 (make-false) ;; #f
+;; 55 (cons)
+;; 56 (list 0 4) ;; 4 elements
+;; 59 (load-program ##{66}#)
+;; 81 (define "loop")
+;; 87 (variable-set)
+;; 88 (void)
+;; 89 (return)
+
+;; Bytecode ##{66}#:
+
+;; 0 (make-int8 0) ;; 0
+;; 2 (local-ref 0)
+;; 4 (ee?)
+;; 5 (br-if-not 0 3) ;; -> 11
+;; 8 (make-int8 0) ;; 0
+;; 10 (return)
+;; 11 (toplevel-ref 0)
+;; 13 (local-ref 0)
+;; 15 (make-int8 1) ;; 1
+;; 17 (sub)
+;; 18 (tail-call 1)
+
+(define (loopi n)
+ ;; Same as `loop'.
+ (let loopi ((n n))
+ (if (= 0 n)
+ 0
+ (loopi (1- n)))))
+
+(define (do-loop n)
+ ;; Same as `loop' using `do'.
+ (do ((i n (1- i)))
+ ((= 0 i))
+ ;; do nothing
+ ))
+
+
+(define (do-cons x)
+ ;; This one shows that the built-in `cons' instruction yields a significant
+ ;; improvement (speedup: 1.5).
+ (let loop ((x x)
+ (result '()))
+ (if (<= x 0)
+ result
+ (loop (1- x) (cons x result)))))
+
+(define big-list (iota 500000))
+
+(define (copy-list lst)
+ ;; Speedup: 5.9.
+ (let loop ((lst lst)
+ (result '()))
+ (if (null? lst)
+ result
+ (loop (cdr lst)
+ (cons (car lst) result)))))
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(measure)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+
+;; A simple interpreter vs. VM performance comparison tool
+;;
+
+(define-module (measure)
+ :export (measure)
+ :use-module (system vm vm)
+ :use-module (system base compile)
+ :use-module (system base language))
+
+
+(define (time-for-eval sexp eval)
+ (let ((before (tms:utime (times))))
+ (eval sexp)
+ (let ((elapsed (- (tms:utime (times)) before)))
+ (format #t "elapsed time: ~a~%" elapsed)
+ elapsed)))
+
+(define *scheme* (lookup-language 'scheme))
+
+\f
+(define (measure . args)
+ (if (< (length args) 2)
+ (begin
+ (format #t "Usage: measure SEXP FILE-TO-LOAD...~%")
+ (format #t "~%")
+ (format #t "Example: measure '(loop 23424)' lib.scm~%~%")
+ (exit 1)))
+ (for-each load (cdr args))
+ (let* ((sexp (with-input-from-string (car args)
+ (lambda ()
+ (read))))
+ (eval-here (lambda (sexp) (eval sexp (current-module))))
+ (proc-name (car sexp))
+ (proc-source (procedure-source (eval proc-name (current-module))))
+ (% (format #t "proc: ~a~%source: ~a~%" proc-name proc-source))
+ (time-interpreted (time-for-eval sexp eval-here))
+ (& (if (defined? proc-name)
+ (eval `(set! ,proc-name #f) (current-module))
+ (format #t "unbound~%")))
+ (the-program (compile proc-source))
+
+ (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)
define(GUILE_CONFIGURE_COPYRIGHT,[[
-Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
This file is part of GUILE
AC_C_BIGENDIAN
+AC_C_LABELS_AS_VALUES
+
AC_CHECK_SIZEOF(char)
AC_CHECK_SIZEOF(unsigned char)
AC_CHECK_SIZEOF(short)
examples/safe/Makefile
examples/scripts/Makefile
guile-config/Makefile
- ice-9/Makefile
- ice-9/debugger/Makefile
- ice-9/debugging/Makefile
lang/Makefile
lang/elisp/Makefile
lang/elisp/internals/Makefile
lang/elisp/primitives/Makefile
libguile/Makefile
- oop/Makefile
- oop/goops/Makefile
scripts/Makefile
srfi/Makefile
test-suite/Makefile
test-suite/standalone/Makefile
+ module/Makefile
+ module/ice-9/Makefile
+ module/ice-9/debugger/Makefile
+ module/ice-9/debugging/Makefile
+ module/srfi/Makefile
+ module/oop/Makefile
+ module/oop/goops/Makefile
+ testsuite/Makefile
])
AC_CONFIG_FILES([guile-1.8.pc])
AC_CONFIG_FILES([guile-tools], [chmod +x guile-tools])
AC_CONFIG_FILES([pre-inst-guile], [chmod +x pre-inst-guile])
AC_CONFIG_FILES([pre-inst-guile-env], [chmod +x pre-inst-guile-env])
+AC_CONFIG_FILES([gdb-pre-inst-guile], [chmod +x gdb-pre-inst-guile])
AC_CONFIG_FILES([libguile/guile-snarf],
[chmod +x libguile/guile-snarf])
AC_CONFIG_FILES([libguile/guile-doc-snarf],
( cd $(top_builddir) ; $(mscripts)/update-guile-api.alist )
guile-api.alist-FORCE:
+info_TEXINFOS = guile-vm.texi
--- /dev/null
+From: Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+Subject: Re: After GOOPS integration: Computation with native types!
+To: Keisuke Nishida <kxn30@po.cwru.edu>
+Cc: djurfeldt@nada.kth.se, guile@sourceware.cygnus.com
+Cc: djurfeldt@nada.kth.se
+Date: 17 Aug 2000 03:01:13 +0200
+
+Keisuke Nishida <kxn30@po.cwru.edu> writes:
+
+> Do I need to include some special feature in my VM? Hmm, but maybe
+> I shouldn't do that now...
+
+Probably not, so I probably shouldn't answer, but... :)
+
+You'll need to include some extremely efficient mechanism to do
+multi-method dispatch. The SCM_IM_DISPATCH form, with its
+implementation at line 2250 in eval.c, is the current basis for
+efficient dispatch in GOOPS.
+
+I think we should develop a new instruction for the VM which
+corresponds to the SCM_IM_DISPATCH form.
+
+This form serves both the purpose to map argument types to the correct
+code, and as a cache of compiled methods.
+
+Notice that I talk about cmethods below, not methods. In GOOPS, the
+GF has a set of methods, but each method has a "code-table" mapping
+argument types to code compiled for those particular concrete types.
+(So, in essence, GOOPS methods abstractly do a deeper level of type
+dispatch.)
+
+The SCM_IM_DISPATCH form has two shapes, depending on whether we use
+sequential search (few cmethods) or hashed lookup (many cmethods).
+
+Shape 1:
+
+ (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
+
+Shape 2:
+
+ (#@dispatch args N-SPECIALIZED HASHSET MASK
+ #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
+ GF)
+
+`args' is (I hope!) a now historic obscure optimization.
+
+N-SPECIALIZED is the maximum number of arguments t do type checking
+on. This is used early termination of argument checking where the
+already checked arguments are enough to pick out the cmethod.
+
+The vector is the cache proper.
+
+During sequential search the argument types are simply checked against
+each entry.
+
+The method for hashed dispatch is described in:
+
+http://www.parc.xerox.com/csl/groups/sda/publications/papers/Kiczales-Andreas-PCL
+
+In this method, each class has a hash code. Dispatch means summing
+the hash codes for all arguments (up til N-SPECIALIZED) and using the
+sum to pick a location in the cache. The cache is sequentially
+searched for an argument type match from that point.
+
+Kiczales introduced a clever method to maximize the probability of a
+direct cache hit. We actually have 8 separate sets of hash codes for
+all types. The hash set to use is selected specifically per GF and is
+optimized to give fastest average hit.
+
+
+What we could try to do as soon as the VM is complete enough is to
+represent the cmethods as chunks of byte code. In the current GOOPS
+code, the compilation step (which is currently empty) is situated in
+`compile-cmethod' in guile-oops/compile.scm. [Apologies for the
+terrible code. That particular part was written at Arlanda airport
+after a sleepless night (packing luggage, not coding), on my way to
+visit Marius (who, BTW, didn't take GOOPS seriously. ;-)]
+
--- /dev/null
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename guile-vm.info
+@settitle Guile VM Specification
+@footnotestyle end
+@setchapternewpage odd
+@c %**end of header
+
+@set EDITION 0.6
+@set VERSION 0.6
+@set UPDATED 2005-04-26
+
+@c Macro for instruction definitions.
+@macro insn{}
+Instruction
+@end macro
+
+@c For Scheme procedure definitions.
+@macro scmproc{}
+Scheme Procedure
+@end macro
+
+@c Scheme records.
+@macro scmrec{}
+Record
+@end macro
+
+@ifinfo
+@dircategory Scheme Programming
+@direntry
+* Guile VM: (guile-vm). Guile's Virtual Machine.
+@end direntry
+
+This file documents Guile VM.
+
+Copyright @copyright{} 2000 Keisuke Nishida
+Copyright @copyright{} 2005 Ludovic Court`es
+
+Permission is granted to make and distribute verbatim copies of this
+manual provided the copyright notice and this permission notice are
+preserved on all copies.
+
+@ignore
+Permission is granted to process this file through TeX and print the
+results, provided the printed document carries a copying permission
+notice identical to this one except for the removal of this paragraph
+(this paragraph not being relevant to the printed manual).
+
+@end ignore
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the
+entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions,
+except that this permission notice may be stated in a translation
+approved by the Free Software Foundation.
+@end ifinfo
+
+@titlepage
+@title Guile VM Specification
+@subtitle for Guile VM @value{VERSION}
+@author Keisuke Nishida
+
+@page
+@vskip 0pt plus 1filll
+Edition @value{EDITION} @*
+Updated for Guile VM @value{VERSION} @*
+@value{UPDATED} @*
+
+Copyright @copyright{} 2000 Keisuke Nishida
+Copyright @copyright{} 2005 Ludovic Court`es
+
+Permission is granted to make and distribute verbatim copies of this
+manual provided the copyright notice and this permission notice are
+preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the
+entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions,
+except that this permission notice may be stated in a translation
+approved by the Free Software Foundation.
+@end titlepage
+
+@contents
+
+@c *********************************************************************
+@node Top, Introduction, (dir), (dir)
+@top Guile VM Specification
+
+This document would like to correspond to Guile VM @value{VERSION}.
+However, be warned that important parts still correspond to version
+0.0 and are not valid anymore.
+
+@menu
+* Introduction::
+* Variable Management::
+* Instruction Set::
+* The Compiler::
+* Concept Index::
+* Function and Instruction Index::
+* Command and Variable Index::
+
+@detailmenu
+ --- The Detailed Node Listing ---
+
+Instruction Set
+
+* Environment Control Instructions::
+* Branch Instructions::
+* Subprogram Control Instructions::
+* Data Control Instructions::
+
+The Compiler
+
+* Overview::
+* The Language Front-Ends::
+* GHIL::
+* Compiling Scheme Code::
+* GLIL::
+* The Assembler::
+
+@end detailmenu
+@end menu
+
+@c *********************************************************************
+@node Introduction, Variable Management, Top, Top
+@chapter What is Guile VM?
+
+A Guile VM has a set of registers and its own stack memory. Guile may
+have more than one VM's. Each VM may execute at most one program at a
+time. Guile VM is a CISC system so designed as to execute Scheme and
+other languages efficiently.
+
+@unnumberedsubsec Registers
+
+@itemize
+@item pc - Program counter ;; ip (instruction poiner) is better?
+@item sp - Stack pointer
+@item bp - Base pointer
+@item ac - Accumulator
+@end itemize
+
+@unnumberedsubsec Engine
+
+A VM may have one of three engines: reckless, regular, or debugging.
+Reckless engine is fastest but dangerous. Regular engine is normally
+fail-safe and reasonably fast. Debugging engine is safest and
+functional but very slow.
+
+@unnumberedsubsec Memory
+
+Stack is the only memory that each VM owns. The other memory is shared
+memory that is shared among every VM and other part of Guile.
+
+@unnumberedsubsec Program
+
+A VM program consists of a bytecode that is executed and an environment
+in which execution is done. Each program is allocated in the shared
+memory and may be executed by any VM. A program may call other programs
+within a VM.
+
+@unnumberedsubsec Instruction
+
+Guile VM has dozens of system instructions and (possibly) hundreds of
+functional instructions. Some Scheme procedures such as cons and car
+are implemented as VM's builtin functions, which are very efficient.
+Other procedures defined outside of the VM are also considered as VM's
+functional features, since they do not change the state of VM.
+Procedures defined within the VM are called subprograms.
+
+Most instructions deal with the accumulator (ac). The VM stores all
+results from functions in ac, instead of pushing them into the stack.
+I'm not sure whether this is a good thing or not.
+
+@node Variable Management, Instruction Set, Introduction, Top
+@chapter Variable Management
+
+FIXME: This chapter needs to be reviewed so that it matches reality.
+A more up-to-date description of the mechanisms described in this
+section is given in @ref{Instruction Set}.
+
+A program may have access to local variables, external variables, and
+top-level variables.
+
+@section Local/external variables
+
+A stack is logically divided into several blocks during execution. A
+"block" is such a unit that maintains local variables and dynamic chain.
+A "frame" is an upper level unit that maintains subprogram calls.
+
+@example
+ Stack
+ dynamic | | | |
+ chain +==========+ - =
+ | |local vars| | |
+ `-|block data| | block |
+ /|frame data| | |
+ | +----------+ - |
+ | |local vars| | | frame
+ `-|block data| | |
+ /+----------+ - |
+ | |local vars| | |
+ `-|block data| | |
+ /+==========+ - =
+ | |local vars| | |
+ `-|block data| | |
+ /|frame data| | |
+ | +----------+ - |
+ | | | | |
+@end example
+
+The first block of each frame may look like this:
+
+@example
+ Address Data
+ ------- ----
+ xxx0028 Local variable 2
+ xxx0024 Local variable 1
+ bp ->xxx0020 Local variable 0
+ xxx001c Local link (block data)
+ xxx0018 External link (block data)
+ xxx0014 Stack pointer (block data)
+ xxx0010 Return address (frame data)
+ xxx000c Parent program (frame data)
+@end example
+
+The base pointer (bp) always points to the lowest address of local
+variables of the recent block. Local variables are referred as "bp[n]".
+The local link field has a pointer to the dynamic parent of the block.
+The parent's variables are referred as "bp[-1][n]", and grandparent's
+are "bp[-1][-1][n]". Thus, any local variable is represented by its
+depth and offset from the current bp.
+
+A variable may be "external", which is allocated in the shared memory.
+The external link field of a block has a pointer to such a variable set,
+which I call "fragment" (what should I call?). A fragment has a set of
+variables and its own chain.
+
+@example
+ local external
+ chain| | chain
+ | +-----+ .--------, |
+ `-|block|--+->|external|-'
+ /+-----+ | `--------'\,
+ `-|block|--' |
+ /+-----+ .--------, |
+ `-|block|---->|external|-'
+ +-----+ `--------'
+ | |
+@end example
+
+An external variable is referred as "bp[-2]->variables[n]" or
+"bp[-2]->link->...->variables[n]". This is also represented by a pair
+of depth and offset. At any point of execution, the value of bp
+determines the current local link and external link, and thus the
+current environment of a program.
+
+Other data fields are described later.
+
+@section Top-level variables
+
+Guile VM uses the same top-level variables as the regular Guile. A
+program may have direct access to vcells. Currently this is done by
+calling scm_intern0, but a program is possible to have any top-level
+environment defined by the current module.
+
+@section Scheme and VM variable
+
+Let's think about the following Scheme code as an example:
+
+@example
+ (define (foo a)
+ (lambda (b) (list foo a b)))
+@end example
+
+In the lambda expression, "foo" is a top-level variable, "a" is an
+external variable, and "b" is a local variable.
+
+When a VM executes foo, it allocates a block for "a". Since "a" may be
+externally referred from the closure, the VM creates a fragment with a
+copy of "a" in it. When the VM evaluates the lambda expression, it
+creates a subprogram (closure), associating the fragment with the
+subprogram as its external environment. When the closure is executed,
+its environment will look like this:
+
+@example
+ block Top-level: foo
+ +-------------+
+ |local var: b | fragment
+ +-------------+ .-----------,
+ |external link|---->|variable: a|
+ +-------------+ `-----------'
+@end example
+
+The fragment remains as long as the closure exists.
+
+@section Addressing mode
+
+Guile VM has five addressing modes:
+
+@itemize
+@item Real address
+@item Local position
+@item External position
+@item Top-level location
+@item Constant object
+@end itemize
+
+Real address points to the address in the real program and is only used
+with the program counter (pc).
+
+Local position and external position are represented as a pair of depth
+and offset from bp, as described above. These are base relative
+addresses, and the real address may vary during execution.
+
+Top-level location is represented as a Guile's vcell. This location is
+determined at loading time, so the use of this address is efficient.
+
+Constant object is not an address but gives an instruction an Scheme
+object directly.
+
+[ We'll also need dynamic scope addressing to support Emacs Lisp? ]
+
+
+Overall procedure:
+
+@enumerate
+@item A source program is compiled into a bytecode.
+@item A bytecode is given an environment and becomes a program.
+@item A VM starts execution, creating a frame for it.
+@item Whenever a program calls a subprogram, a new frame is created for it.
+@item When a program finishes execution, it returns a value, and the VM
+ continues execution of the parent program.
+@item When all programs terminated, the VM returns the final value and stops.
+@end enumerate
+
+\f
+@node Instruction Set, The Compiler, Variable Management, Top
+@chapter Instruction Set
+
+The Guile VM instruction set is roughly divided two groups: system
+instructions and functional instructions. System instructions control
+the execution of programs, while functional instructions provide many
+useful calculations.
+
+@menu
+* Environment Control Instructions::
+* Branch Instructions::
+* Subprogram Control Instructions::
+* Data Control Instructions::
+@end menu
+
+@node Environment Control Instructions, Branch Instructions, Instruction Set, Instruction Set
+@section Environment Control Instructions
+
+@deffn @insn{} link binding-name
+Look up @var{binding-name} (a string) in the current environment and
+push the corresponding variable object onto the stack. If
+@var{binding-name} is not bound yet, then create a new binding and
+push its variable object.
+@end deffn
+
+@deffn @insn{} variable-ref
+Dereference the variable object which is on top of the stack and
+replace it by the value of the variable it represents.
+@end deffn
+
+@deffn @insn{} variable-set
+Set the value of the variable on top of the stack (at @code{sp[0]}) to
+the object located immediately before (at @code{sp[-1]}).
+@end deffn
+
+As an example, let us look at what a simple function call looks like:
+
+@example
+(+ 2 3)
+@end example
+
+This call yields the following sequence of instructions:
+
+@example
+(link "+") ;; lookup binding "+"
+(variable-ref) ;; dereference it
+(make-int8 2) ;; push immediate value `2'
+(make-int8 3) ;; push immediate value `3'
+(tail-call 2) ;; call the proc at sp[-3] with two args
+@end example
+
+@deffn @insn{} local-ref offset
+Push onto the stack the value of the local variable located at
+@var{offset} within the current stack frame.
+@end deffn
+
+@deffn @insn{} local-set offset
+Pop the Scheme object located on top of the stack and make it the new
+value of the local variable located at @var{offset} within the current
+stack frame.
+@end deffn
+
+@deffn @insn{} external-ref offset
+Push the value of the closure variable located at position
+@var{offset} within the program's list of external variables.
+@end deffn
+
+@deffn @insn{} external-set offset
+Pop the Scheme object located on top of the stack and make it the new
+value of the closure variable located at @var{offset} within the
+program's list of external variables.
+@end deffn
+
+@deffn @insn{} make-closure
+Pop the program object from the stack and assign it the current
+closure variable list as its closure. Push the result program
+object.
+@end deffn
+
+Let's illustrate this:
+
+@example
+(let ((x 2))
+ (lambda ()
+ (let ((x++ (+ 1 x)))
+ (set! x x++)
+ x++)))
+@end example
+
+The resulting program has one external (closure) variable, i.e. its
+@var{nexts} is set to 1 (@pxref{Subprogram Control Instructions}).
+This yields the following code:
+
+@example
+ ;; the traditional program prologue with NLOCS = 0 and NEXTS = 1
+
+ 0 (make-int8 2)
+ 2 (external-set 0)
+ 4 (make-int8 4)
+ 6 (link "+") ;; lookup `+'
+ 9 (vector 1) ;; create the external variable vector for
+ ;; later use by `object-ref' and `object-set'
+ ...
+ 40 (load-program ##34#)
+ 59 (make-closure) ;; assign the current closure to the program
+ ;; just pushed by `load-program'
+ 60 (return)
+@end example
+
+The program loaded here by @var{load-program} contains the following
+sequence of instructions:
+
+@example
+ 0 (object-ref 0) ;; push the variable for `+'
+ 2 (variable-ref) ;; dereference `+'
+ 3 (make-int8:1) ;; push 1
+ 4 (external-ref 0) ;; push the value of `x'
+ 6 (call 2) ;; call `+' and push the result
+ 8 (local-set 0) ;; make it the new value of `x++'
+ 10 (local-ref 0) ;; push the value of `x++'
+ 12 (external-set 0) ;; make it the new value of `x'
+ 14 (local-ref 0) ;; push the value of `x++'
+ 16 (return) ;; return it
+@end example
+
+At this point, you should know pretty much everything about the three
+types of variables a program may need to access.
+
+
+@node Branch Instructions, Subprogram Control Instructions, Environment Control Instructions, Instruction Set
+@section Branch Instructions
+
+All the conditional branch instructions described below work in the
+same way:
+
+@itemize
+@item They take the Scheme object located on the stack and use it as
+the branch condition;
+@item If the condition if false, then program execution continues with
+the next instruction;
+@item If the condition is true, then the instruction pointer is
+increased by the offset passed as an argument to the branch
+instruction;
+@item Finally, when the instruction finished, the condition object is
+removed from the stack.
+@end itemize
+
+Note that the offset passed to the instruction is encoded on two 8-bit
+integers which are then combined by the VM as one 16-bit integer.
+
+@deffn @insn{} br offset
+Jump to @var{offset}.
+@end deffn
+
+@deffn @insn{} br-if offset
+Jump to @var{offset} if the condition on the stack is not false.
+@end deffn
+
+@deffn @insn{} br-if-not offset
+Jump to @var{offset} if the condition on the stack is false.
+@end deffn
+
+@deffn @insn{} br-if-eq offset
+Jump to @var{offset} if the two objects located on the stack are
+equal in the sense of @var{eq?}. Note that, for this instruction, the
+stack pointer is decremented by two Scheme objects instead of only
+one.
+@end deffn
+
+@deffn @insn{} br-if-not-eq offset
+Same as @var{br-if-eq} for non-equal objects.
+@end deffn
+
+@deffn @insn{} br-if-null offset
+Jump to @var{offset} if the object on the stack is @code{'()}.
+@end deffn
+
+@deffn @insn{} br-if-not-null offset
+Jump to @var{offset} if the object on the stack is not @code{'()}.
+@end deffn
+
+
+@node Subprogram Control Instructions, Data Control Instructions, Branch Instructions, Instruction Set
+@section Subprogram Control Instructions
+
+Programs (read: ``compiled procedure'') may refer to external
+bindings, like variables or functions defined outside the program
+itself, in the environment in which it will evaluate at run-time. In
+a sense, a program's environment and its bindings are an implicit
+parameter of every program.
+
+@cindex object table
+In order to handle such bindings, each program has an @dfn{object
+table} associated to it. This table (actually a Scheme vector)
+contains all constant objects referenced by the program. The object
+table of a program is initialized right before a program is loaded
+with @var{load-program}.
+
+Variable objects are one such type of constant object: when a global
+binding is defined, a variable object is associated to it and that
+object will remain constant over time, even if the value bound to it
+changes. Therefore, external bindings only need to be looked up once
+when the program is loaded. References to the corresponding external
+variables from within the program are then performed via the
+@var{object-ref} instruction and are almost as fast as local variable
+references.
+
+Let us consider the following program (procedure) which references
+external bindings @code{frob} and @var{%magic}:
+
+@example
+(lambda (x)
+ (frob x %magic))
+@end example
+
+This yields the following assembly code:
+
+@example
+(make-int8 64) ;; number of args, vars, etc. (see below)
+(link "frob")
+(link "%magic")
+(vector 2) ;; object table (external bindings)
+...
+(load-program #u8(20 0 23 21 0 20 1 23 36 2))
+(return)
+@end example
+
+All the instructions occurring before @var{load-program} (some were
+omitted for simplicity) form a @dfn{prologue} which, among other
+things, pushed an object table (a vector) that contains the variable
+objects for the variables bound to @var{frob} and @var{%magic}. This
+vector and other data pushed onto the stack are then popped by the
+@var{load-program} instruction.
+
+Besides, the @var{load-program} instruction takes one explicit
+argument which is the bytecode of the program itself. Disassembled,
+this bytecode looks like:
+
+@example
+(object-ref 0) ;; push the variable object of `frob'
+(variable-ref) ;; dereference it
+(local-ref 0) ;; push the value of `x'
+(object-ref 1) ;; push the variable object of `%magic'
+(variable-ref) ;; dereference it
+(tail-call 2) ;; call `frob' with two parameters
+@end example
+
+This clearly shows that there is little difference between references
+to local variables and references to externally bound variables since
+lookup of externally bound variables if performed only once before the
+program is run.
+
+@deffn @insn{} load-program bytecode
+Load the program whose bytecode is @var{bytecode} (a u8vector), pop
+its meta-information from the stack, and push a corresponding program
+object onto the stack. The program's meta-information may consist of
+(in the order in which it should be pushed onto the stack):
+
+@itemize
+@item optionally, a pair representing meta-data (see the
+@var{program-meta} procedure); [FIXME: explain their meaning]
+@item optionally, a vector which is the program's object table (a
+program that does not reference external bindings does not need an
+object table);
+@item either one immediate integer or four immediate integers
+representing respectively the number of arguments taken by the
+function (@var{nargs}), the number of @dfn{rest arguments}
+(@var{nrest}, 0 or 1), the number of local variables (@var{nlocs}) and
+the number of external variables (@var{nexts}) (@pxref{Environment
+Control Instructions}).
+@end itemize
+
+@end deffn
+
+@deffn @insn{} object-ref offset
+Push the variable object for the external variable located at
+@var{offset} within the program's object table.
+@end deffn
+
+@deffn @insn{} return
+Free the program's frame.
+@end deffn
+
+@deffn @insn{} call nargs
+Call the procedure, continuation or program located at
+@code{sp[-nargs]} with the @var{nargs} arguments located from
+@code{sp[0]} to @code{sp[-nargs + 1]}. The
+procedure/continuation/program and its arguments are dropped from the
+stack and the result is pushed. When calling a program, the
+@code{call} instruction reserves room for its local variables on the
+stack, and initializes its list of closure variables and its vector of
+externally bound variables.
+@end deffn
+
+@deffn @insn{} tail-call nargs
+Same as @code{call} except that, for tail-recursive calls to a
+program, the current stack frame is re-used, as required by RnRS.
+This instruction is otherwise similar to @code{call}.
+@end deffn
+
+
+@node Data Control Instructions, , Subprogram Control Instructions, Instruction Set
+@section Data Control Instructions
+
+@deffn @insn{} make-int8 value
+Push @var{value}, an 8-bit integer, onto the stack.
+@end deffn
+
+@deffn @insn{} make-int8:0
+Push the immediate value @code{0} onto the stack.
+@end deffn
+
+@deffn @insn{} make-int8:1
+Push the immediate value @code{1} onto the stack.
+@end deffn
+
+@deffn @insn{} make-false
+Push @code{#f} onto the stack.
+@end deffn
+
+@deffn @insn{} make-true
+Push @code{#t} onto the stack.
+@end deffn
+
+@itemize
+@item %push
+@item %pushi
+@item %pushl, %pushl:0:0, %pushl:0:1, %pushl:0:2, %pushl:0:3
+@item %pushe, %pushe:0:0, %pushe:0:1, %pushe:0:2, %pushe:0:3
+@item %pusht
+@end itemize
+
+@itemize
+@item %loadi
+@item %loadl, %loadl:0:0, %loadl:0:1, %loadl:0:2, %loadl:0:3
+@item %loade, %loade:0:0, %loade:0:1, %loade:0:2, %loade:0:3
+@item %loadt
+@end itemize
+
+@itemize
+@item %savei
+@item %savel, %savel:0:0, %savel:0:1, %savel:0:2, %savel:0:3
+@item %savee, %savee:0:0, %savee:0:1, %savee:0:2, %savee:0:3
+@item %savet
+@end itemize
+
+@section Flow control instructions
+
+@itemize
+@item %br-if
+@item %br-if-not
+@item %jump
+@end itemize
+
+@section Function call instructions
+
+@itemize
+@item %func, %func0, %func1, %func2
+@end itemize
+
+@section Scheme built-in functions
+
+@itemize
+@item cons
+@item car
+@item cdr
+@end itemize
+
+@section Mathematical buitin functions
+
+@itemize
+@item 1+
+@item 1-
+@item add, add2
+@item sub, sub2, minus
+@item mul2
+@item div2
+@item lt2
+@item gt2
+@item le2
+@item ge2
+@item num-eq2
+@end itemize
+
+
+\f
+@node The Compiler, Concept Index, Instruction Set, Top
+@chapter The Compiler
+
+This section describes Guile-VM's compiler and the compilation process
+to produce bytecode executable by the VM itself (@pxref{Instruction
+Set}).
+
+@menu
+* Overview::
+* The Language Front-Ends::
+* GHIL::
+* Compiling Scheme Code::
+* GLIL::
+* The Assembler::
+@end menu
+
+@node Overview, The Language Front-Ends, The Compiler, The Compiler
+@section Overview
+
+Compilation in Guile-VM is a three-stage process:
+
+@cindex intermediate language
+@cindex assembler
+@cindex compiler
+@cindex GHIL
+@cindex GLIL
+@cindex bytecode
+
+@enumerate
+@item the source programming language (e.g. R5RS Scheme) is read and
+translated into GHIL, @dfn{Guile's High-Level Intermediate Language};
+@item GHIL code is then translated into a lower-level intermediate
+language call GLIL, @dfn{Guile's Low-Level Intermediate Language};
+@item finally, GLIL is @dfn{assembled} into the VM's assembly language
+(@pxref{Instruction Set}) and bytecode.
+@end enumerate
+
+The use of two separate intermediate languages eases the
+implementation of front-ends since the gap between high-level
+languages like Scheme and GHIL is relatively small.
+
+@vindex guilec
+From an end-user viewpoint, compiling a Guile program into bytecode
+can be done either by using the @command{guilec} command-line tool, or
+by using the @code{compile-file} procedure exported by the
+@code{(system base compile)} module.
+
+@deffn @scmproc{} compile-file file . opts
+Compile Scheme source code from file @var{file} using compilation
+options @var{opts}. The resulting file, a Guile object file, will be
+name according the application of the @code{compiled-file-name}
+procedure to @var{file}. The possible values for @var{opts} are the
+same as for the @code{compile-in} procedure (see below, @pxref{The Language
+Front-Ends}).
+@end deffn
+
+@deffn @scmproc{} compiled-file-name file
+Given source file name @var{file} (a string), return a string that
+denotes the name of the Guile object file corresponding to
+@var{file}. By default, the file name returned is @var{file} minus
+its extension and plus the @code{.go} file extension.
+@end deffn
+
+@cindex self-hosting
+It is worth noting, as you might have already guessed, that Guile-VM's
+compiler is written in Guile Scheme and is @dfn{self-hosted}: it can
+compile itself.
+
+@node The Language Front-Ends, GHIL, Overview, The Compiler
+@section The Language Front-Ends
+
+Guile-VM comes with a number of @dfn{language front-ends}, that is,
+code that can read a given high-level programming language like R5RS
+Scheme, and translate it into a lower-level representation suitable to
+the compiler.
+
+Each language front-end provides a @dfn{specification} and a
+@dfn{translator} to GHIL. Both of them come in the @code{language}
+module hierarchy. As an example, the front-end for Scheme is located
+in the @code{(language scheme spec)} and @code{(language scheme
+translate)} modules. Language front-ends can then be retrieved using
+the @code{lookup-language} procedure of the @code{(system base
+language)} module.
+
+@deftp @scmrec{} <language> name title version reader printer read-file expander translator evaluator environment
+Denotes a language front-end specification a various methods used by
+the compiler to handle source written in that language. Of particular
+interest is the @code{translator} slot (@pxref{GHIL}).
+@end deftp
+
+@deffn @scmproc{} lookup-language lang
+Look for a language front-end named @var{lang}, a symbol (e.g,
+@code{scheme}), and return the @code{<language>} record describing it
+if found. If @var{lang} does not denote a language front-end, an
+error is raised. Note that this procedure assumes that language
+@var{lang} exists if there exist a @code{(language @var{lang} spec)}
+module.
+@end deffn
+
+The @code{(system base compile)} module defines a procedure similar to
+@code{compile-file} but that is not limited to the Scheme language:
+
+@deffn @scmproc{} compile-in expr env lang . opts
+Compile expression @var{expr}, which is written in language @var{lang}
+(a @code{<language>} object), using compilation options @var{opts},
+and return bytecode as produced by the assembler (@pxref{The
+Assembler}).
+
+Options @var{opts} may contain the following keywords:
+
+@table @code
+@item :e
+compilation will stop after the code expansion phase.
+@item :t
+compilation will stop after the code translation phase, i.e. after
+code in the source language @var{lang} has been translated into GHIL
+(@pxref{GHIL}).
+@item :c
+compilation will stop after the compilation phase and before the
+assembly phase, i.e. once GHIL has been translated into GLIL
+(@pxref{GLIL}).
+@end table
+
+Additionally, @var{opts} may contain any option understood by the
+GHIL-to-GLIL compiler described in @xref{GLIL}.
+@end deffn
+
+
+@node GHIL, Compiling Scheme Code, The Language Front-Ends, The Compiler
+@section Guile's High-Level Intermediate Language
+
+GHIL has constructs almost equivalent to those found in Scheme.
+However, unlike Scheme, it is meant to be read only by the compiler
+itself. Therefore, a sequence of GHIL code is only a sequence of GHIL
+@emph{objects} (records), as opposed to symbols, each of which
+represents a particular language feature. These records are all
+defined in the @code{(system il ghil)} module and are named
+@code{<ghil-*>}.
+
+Each GHIL record has at least two fields: one containing the
+environment (Guile module) in which it is considered, and one
+containing its location [FIXME: currently seems to be unused]. Below
+is a list of the main GHIL object types and their fields:
+
+@example
+;; Objects
+(<ghil-void> env loc)
+(<ghil-quote> env loc obj)
+(<ghil-quasiquote> env loc exp)
+(<ghil-unquote> env loc exp)
+(<ghil-unquote-splicing> env loc exp)
+;; Variables
+(<ghil-ref> env loc var)
+(<ghil-set> env loc var val)
+(<ghil-define> env loc var val)
+;; Controls
+(<ghil-if> env loc test then else)
+(<ghil-and> env loc exps)
+(<ghil-or> env loc exps)
+(<ghil-begin> env loc exps)
+(<ghil-bind> env loc vars vals body)
+(<ghil-lambda> env loc vars rest body)
+(<ghil-call> env loc proc args)
+(<ghil-inline> env loc inline args)
+@end example
+
+As can be seen from this examples, the constructs in GHIL are pretty
+close to the fundamental primitives of Scheme.
+
+It is the role of front-end language translators (@pxref{The Language
+Front-Ends}) to produce a sequence of GHIL objects from the
+human-readable, source programming language. The next section
+describes the translator for the Scheme language.
+
+@node Compiling Scheme Code, GLIL, GHIL, The Compiler
+@section Compiling Scheme Code
+
+The language object for Scheme, as returned by @code{(lookup-language
+'scheme)} (@pxref{The Language Front-Ends}), defines a translator
+procedure that returns a sequence of GHIL objects given Scheme code.
+Before actually performing this operation, the Scheme translator
+expands macros in the original source code.
+
+The macros that may be expanded can come from different sources:
+
+@itemize
+@item core Guile macros, such as @code{false-if-exception};
+@item macros defined in modules used by the module being compiled,
+e.g., @code{receive} in @code{(ice-9 receive)};
+@item macros defined within the module being compiled.
+@end itemize
+
+@cindex macro
+@cindex syntax transformer
+@findex define-macro
+@findex defmacro
+The main complexity in handling macros at compilation time is that
+Guile's macros are first-class objects. For instance, when using
+@code{define-macro}, one actually defines a @emph{procedure} that
+returns code; of course, unlike a ``regular'' procedure, it is
+executed when an S-exp is @dfn{memoized} by the evaluator, i.e.,
+before the actual evaluation takes place. Worse, it is possible to
+turn a procedure into a macro, or @dfn{syntax transformer}, thus
+removing, to some extent, the boundary between the macro expansion and
+evaluation phases, @inforef{Internal Macros, , guile}.
+
+[FIXME: explain limitations, etc.]
+
+
+@node GLIL, The Assembler, Compiling Scheme Code, The Compiler
+@section Guile's Low-Level Intermediate Language
+
+A GHIL instruction sequence can be compiled into GLIL using the
+@code{compile} procedure exported by the @code{(system il compile)}
+module. During this translation process, various optimizations may
+also be performed.
+
+The module @code{(system il glil)} defines record types representing
+various low-level abstractions. Compared to GHIL, the flow control
+primitives in GLIL are much more low-level: only @code{<glil-label>},
+@code{<glil-branch>} and @code{<glil-call>} are available, no
+@code{lambda}, @code{if}, etc.
+
+
+@deffn @scmproc{} compile ghil environment . opts
+Compile @var{ghil}, a GHIL instruction sequence, within
+environment/module @var{environment}, and return the resulting GLIL
+instruction sequence. The option list @var{opts} may be either the
+empty list or a list containing the @code{:O} keyword in which case
+@code{compile} will first go through an optimization stage of
+@var{ghil}.
+
+Note that the @code{:O} option may be passed at a higher-level to the
+@code{compile-file} and @code{compile-in} procedures (@pxref{The
+Language Front-Ends}).
+@end deffn
+
+@deffn @scmproc{} pprint-glil glil . port
+Print @var{glil}, a GLIL sequence instructions, in a human-readable
+form. If @var{port} is passed, it will be used as the output port.
+@end deffn
+
+
+Let's consider the following Scheme expression:
+
+@example
+(lambda (x) (+ x 1))
+@end example
+
+The corresponding (unoptimized) GLIL code, as shown by
+@code{pprint-glil}, looks like this:
+
+@example
+(@@asm (0 0 0 0)
+ (@@asm (1 0 0 0) ;; expect one arg.
+ (@@bind (x argument 0)) ;; debugging info
+ (module-ref #f +) ;; lookup `+'
+ (argument-ref 0) ;; push the argument onto
+ ;; the stack
+ (const 1) ;; push `1'
+ (tail-call 2) ;; call `+', with 2 args,
+ ;; using the same stack frame
+ (@@source 15 33)) ;; additional debugging info
+ (return 0))
+@end example
+
+This is not unlike the VM's assembly language described in
+@ref{Instruction Set}.
+
+@node The Assembler, , GLIL, The Compiler
+@section The Assembler
+
+@findex code->bytes
+
+The final compilation step consists in converting the GLIL instruction
+sequence into VM bytecode. This is what the @code{assemble} procedure
+defined in the @code{(system vm assemble)} module is for. It relies
+on the @code{code->bytes} procedure of the @code{(system vm conv)}
+module to convert instructions (represented as lists whose @code{car}
+is a symbol naming the instruction, e.g. @code{object-ref},
+@pxref{Instruction Set}) into binary code, or @dfn{bytecode}.
+Bytecode itself is represented using SRFI-4 byte vectors,
+@inforef{SRFI-4, SRFI-4 homogeneous numeric vectors, guile}.
+
+
+@deffn @scmproc{} assemble glil environment . opts
+Return a binary representation of @var{glil} (bytecode), either in the
+form of an SRFI-4 @code{u8vector} or a @code{<bytespec>} object.
+[FIXME: Why is that?]
+@end deffn
+
+
+
+@c *********************************************************************
+@node Concept Index, Function and Instruction Index, The Compiler, Top
+@unnumbered Concept Index
+@printindex cp
+
+@node Function and Instruction Index, Command and Variable Index, Concept Index, Top
+@unnumbered Function and Instruction Index
+@printindex fn
+
+@node Command and Variable Index, , Function and Instruction Index, Top
+@unnumbered Command and Variable Index
+@printindex vr
+
+@bye
+
+@c Local Variables:
+@c ispell-local-dictionary: "american";
+@c End:
+
+@c LocalWords: bytecode
autoconf.texi \
autoconf-macros.texi \
tools.texi \
+ history.texi \
+ vm.texi \
+ compiler.texi \
fdl.texi \
libguile-concepts.texi \
libguile-smobs.texi \
@example
(make-vtable "prpw"
(lambda (struct port)
- (display "#<")
- (display (struct-ref 0))
- (display " and ")
- (display (struct-ref 1))
- (display ">")))
+ (display "#<" port)
+ (display (struct-ref struct 0) port)
+ (display " and " port)
+ (display (struct-ref struct 1) port)
+ (display ">" port)))
@end example
@end deffn
guile>
@end lisp
+@anchor{Memoization}
+@cindex Memoization
(For anyone wondering why the first @code{(do-main 4)} call above
generates lots more trace lines than the subsequent calls: these
examples also demonstrate how the Guile evaluator ``memoizes'' code.
@c See the file guile.texi for copying conditions.
@page
-@node Read/Load/Eval
+@node Read/Load/Eval/Compile
@section Reading and Evaluating Scheme Code
This chapter describes Guile functions that are concerned with reading,
-loading and evaluating Scheme code at run time.
+loading, evaluating, and compiling Scheme code at run time.
@menu
* Scheme Syntax:: Standard and extended Scheme syntax.
* Scheme Read:: Reading Scheme code.
* Fly Evaluation:: Procedures for on the fly evaluation.
+* Compilation:: How to compile Scheme files and procedures.
* Loading:: Loading Scheme code from file.
* Delayed Evaluation:: Postponing evaluation until it is needed.
* Local Evaluation:: Evaluation in a local environment.
* Evaluator Behaviour:: Modifying Guile's evaluator.
+* VM Behaviour:: Modifying Guile's virtual machine.
@end menu
@end deffn
+@node Compilation
+@subsection Compiling Scheme Code
+
+The @code{eval} procedure directly interprets the S-expression
+representation of Scheme. An alternate strategy for evaluation is to
+determine ahead of time what computations will be necessary to
+evaluate the expression, and then use that recipe to produce the
+desired results. This is known as @dfn{compilation}.
+
+While it is possible to compile simple Scheme expressions such as
+@code{(+ 2 2)} or even @code{"Hello world!"}, compilation is most
+interesting in the context of procedures. Compiling a lambda expression
+produces a compiled procedure, which is just like a normal procedure
+except typically much faster, because it can bypass the generic
+interpreter.
+
+Functions from system modules in a Guile installation are normally
+compiled already, so they load and run quickly.
+
+Note that well-written Scheme programs will not typically call the
+procedures in this section, for the same reason that it is often bad
+taste to use @code{eval}. The normal interface to the compiler is the
+command-line file compiler, which can be invoked from the shell as
+@code{guile-tools compile @var{foo.scm}}. This interface needs more
+documentation.
+
+(Why are calls to @code{eval} and @code{compile} usually in bad taste?
+Because they are limited, in that they can only really make sense for
+top-level expressions. Also, most needs for ``compile-time''
+computation are fulfilled by macros and closures. Of course one good
+counterexample is the REPL itself, or any code that reads expressions
+from a port.)
+
+For more information on the compiler itself, see @ref{Compiling to the
+Virtual Machine}. For information on the virtual machine, see @ref{A
+Virtual Machine for Guile}.
+
+@deffn {Scheme Procedure} compile exp [env=#f] [from=(current-language)] [to=value] [opts=()]
+Compile the expression @var{exp} in the environment @var{env}. If
+@var{exp} is a procedure, the result will be a compiled procedure;
+otherwise @code{compile} is mostly equivalent to @code{eval}.
+
+For a discussion of languages and compiler options, @xref{Compiling to
+the Virtual Machine}.
+@end deffn
+
+@deffn {Scheme Procedure} compile-file file [to=objcode] [opts='()]
+Compile the file named @var{file}.
+
+Output will be written to a file in the current directory whose name
+is computed as @code{(compiled-file-name @var{file})}.
+@end deffn
+
+@deffn {Scheme Procedure} compiled-file-name file
+Compute an appropriate name for a compiled version of a Scheme file
+named @var{file}.
+
+Usually, the result will be the original file name with the
+@code{.scm} suffix replaced with @code{.go}, but the exact behavior
+depends on the contents of the @code{%load-extensions} and
+@code{%load-compiled-extensions} lists.
+@end deffn
+
@node Loading
@subsection Loading Scheme Code from File
documentation for @code{%load-hook} later in this section.
@end deffn
+@deffn {Scheme Procedure} load-compiled filename
+Load the compiled file named @var{filename}. The load paths are not
+searched.
+
+Compiling a source file (@pxref{Read/Load/Eval/Compile}) and then
+calling @code{load-compiled} on the resulting file is equivalent to
+calling @code{load} on the source file.
+@end deffn
+
@deffn {Scheme Procedure} load-from-path filename
Similar to @code{load}, but searches for @var{filename} in the load
-paths.
+paths. Preferentially loads a compiled version of the file, if it is
+available and up-to-date.
@end deffn
@deffn {Scheme Procedure} primitive-load filename
Search @code{%load-path} for the file named @var{filename} and
load it into the top-level environment. If @var{filename} is a
relative pathname and is not found in the list of search paths,
-an error is signalled.
+an error is signalled. Preferentially loads a compiled version of the
+file, if it is available and up-to-date.
@end deffn
@deffn {Scheme Procedure} %search-load-path filename
Option interface for the evaluator trap options.
@end deffn
+@node VM Behaviour
+@subsection VM Behaviour
+
+Like the procedures from the previous section that operate on the
+evaluator, there are also procedures to modify the behavior of a
+virtual machine.
+
+The most useful thing that a user can do is to add to one of the
+virtual machine's predefined hooks:
+
+@deffn {Scheme Procedure} vm-next-hook vm
+@deffnx {Scheme Procedure} vm-apply-hook vm
+@deffnx {Scheme Procedure} vm-boot-hook vm
+@deffnx {Scheme Procedure} vm-return-hook vm
+@deffnx {Scheme Procedure} vm-break-hook vm
+@deffnx {Scheme Procedure} vm-exit-hook vm
+@deffnx {Scheme Procedure} vm-halt-hook vm
+@deffnx {Scheme Procedure} vm-enter-hook vm
+Accessors to a virtual machine's hooks. Usually you pass
+@code{(the-vm)} as the @var{vm}.
+@end deffn
+
+@xref{A Virtual Machine for Guile}, for more information on Guile's
+virtual machine.
@c Local Variables:
@c TeX-master: "guile.texi"
@menu
* Lambda:: Basic procedure creation using lambda.
* Primitive Procedures:: Procedures defined in C.
+* Compiled Procedures:: Scheme procedures can be compiled.
* Optional Arguments:: Handling keyword, optional and rest arguments.
* Procedure Properties:: Procedure properties and meta-information.
* Procedures with Setters:: Procedures with setters.
It is advisable to use the gsubr variants since they provide a
slightly higher-level abstraction of the Guile implementation.
+@node Compiled Procedures
+@subsection Compiled Procedures
+
+Procedures that were created when loading a compiled file are
+themselves compiled. (In contrast, procedures that are defined by
+loading a Scheme source file are interpreted, and often not as fast as
+compiled procedures.)
+
+Loading compiled files is the normal way that compiled procedures come
+to being, though procedures can be compiled at runtime as well.
+@xref{Read/Load/Eval/Compile}, for more information on runtime
+compilation.
+
+Compiled procedures, also known as @dfn{programs}, respond all
+procedures that operate on procedures. In addition, there are a few
+more accessors for low-level details on programs.
+
+Most people won't need to use the routines described in this section,
+but it's good to have them documented. You'll have to include the
+appropriate module first, though:
+
+@example
+(use-modules (system vm program))
+@end example
+
+@deffn {Scheme Procedure} program? obj
+@deffnx {C Function} scm_program_p (obj)
+Returns @code{#t} iff @var{obj} is a compiled procedure.
+@end deffn
+
+@deffn {Scheme Procedure} program-bytecode program
+@deffnx {C Function} scm_program_bytecode (program)
+Returns the object code associated with this program, as a
+@code{u8vector}.
+@end deffn
+
+@deffn {Scheme Procedure} program-base program
+@deffnx {C Function} scm_program_base (program)
+Returns the address in memory corresponding to the start of
+@var{program}'s object code, as an integer. This is useful mostly when
+you map the value of an instruction pointer from the VM to actual
+instructions.
+@end deffn
+
+@deffn {Scheme Procedure} program-objects program
+@deffnx {C Function} scm_program_objects (program)
+Returns the ``object table'' associated with this program, as a
+vector. @xref{VM Programs}, for more information.
+@end deffn
+
+@deffn {Scheme Procedure} program-module program
+@deffnx {C Function} scm_program_module (program)
+Returns the module that was current when this program was created.
+Free variables in this program are looked up with respect to this
+module.
+@end deffn
+
+@deffn {Scheme Procedure} program-external program
+@deffnx {C Function} scm_program_external (program)
+Returns the set of heap-allocated variables that this program captures
+in its closure, as a list. If a closure is code with data, you can get
+the code from @code{program-bytecode}, and the data via
+@code{program-external}.
+
+Users must not modify the returned value unless they think they're
+really clever.
+@end deffn
+
+@deffn {Scheme Procedure} program-external-set! program external
+@deffnx {C Function} scm_program_external_set_x (program, external)
+Set @var{external} as the set of closure variables on @var{program}.
+
+The Guile maintainers will not be held responsible for side effects of
+calling this function, including but not limited to replacement of
+shampoo with hair dye, and a slight salty taste in tomorrow's dinner.
+@end deffn
+
+@deffn {Scheme Procedure} program-arity program
+@deffnx {C Function} scm_program_arity (program)
+@deffnx {Scheme Procedure} arity:nargs arity
+@deffnx {Scheme Procedure} arity:nrest arity
+@deffnx {Scheme Procedure} arity:nlocs arity
+@deffnx {Scheme Procedure} arity:nexts arity
+Accessors for a representation of the ``arity'' of a program.
+
+@code{nargs} is the number of arguments to the procedure, and
+@code{nrest} will be non-zero if the last argument is a rest argument.
+
+The other two accessors determine the number of local and external
+(heap-allocated) variables that this procedure will need to have
+allocated.
+@end deffn
+
+@deffn {Scheme Procedure} program-meta program
+@deffnx scm_program_meta (program)
+Return the metadata thunk of @var{program}, or @code{#f} if it has no
+metadata.
+
+When called, a metadata thunk returns a list of the following form:
+@code{(@var{bindings} @var{sources} . @var{properties})}. The format
+of each of these elements is discussed below.
+@end deffn
+
+@deffn {Scheme Procedure} program-bindings program
+@deffnx {Scheme Procedure} make-binding name extp index start end
+@deffnx {Scheme Procedure} binding:name binding
+@deffnx {Scheme Procedure} binding:extp binding
+@deffnx {Scheme Procedure} binding:index binding
+@deffnx {Scheme Procedure} binding:start binding
+@deffnx {Scheme Procedure} binding:end binding
+Bindings annotations for programs, along with their accessors.
+
+Bindings declare names and liveness extents for block-local variables.
+The best way to see what these are is to play around with them at a
+REPL. The only tricky bit is that @var{extp} is a boolean, declaring
+whether the binding is heap-allocated or not. @xref{VM Concepts}, for
+more information.
+
+Note that bindings information are stored in a program as part of its
+metadata thunk, so including them in the generated object code does
+not impose a runtime performance penalty.
+@end deffn
+
+@deffn {Scheme Procedure} program-sources program
+@deffnx {Scheme Procedure} source:addr source
+@deffnx {Scheme Procedure} source:line source
+@deffnx {Scheme Procedure} source:column source
+@deffnx {Scheme Procedure} source:file source
+Source location annotations for programs, along with their accessors.
+
+Source location information propagates through the compiler and ends
+up being serialized to the program's metadata. This information is
+keyed by the offset of the instruction pointer within the object code
+of the program. Specifically, it is keyed on the @code{ip} @emph{just
+following} an instruction, so that backtraces can find the source
+location of a call that is in progress.
+@end deffn
+
+@deffn {Scheme Procedure} program-properties program
+Return the properties of a @code{program} as an association list,
+keyed by property name (a symbol).
+
+Some interesting properties include:
+@itemize
+@item @code{name}, the name of the procedure
+@item @code{documentation}, the procedure's docstring
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} program-property program name
+Access a program's property by name, returning @code{#f} if not found.
+@end deffn
+
+@deffn {Scheme Procedure} program-documentation program
+@deffnx {Scheme Procedure} program-name program
+Accessors for specific properties.
+@end deffn
+
@node Optional Arguments
@subsection Optional Arguments
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2008
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Compiling to the Virtual Machine
+@section Compiling to the Virtual Machine
+
+Compilers have a mystique about them that is attractive and
+off-putting at the same time. They are attractive because they are
+magical -- they transform inert text into live results, like throwing
+the switch on Frankenstein's monster. However, this magic is perceived
+by many to be impenetrable.
+
+This section aims to pay attention to the small man behind the
+curtain.
+
+@xref{Read/Load/Eval/Compile}, if you're lost and you just wanted to
+know how to compile your .scm file.
+
+@menu
+* Compiler Tower::
+* The Scheme Compiler::
+* GHIL::
+* GLIL::
+* Object Code::
+* Extending the Compiler::
+@end menu
+
+@node Compiler Tower
+@subsection Compiler Tower
+
+Guile's compiler is quite simple, actually -- its @emph{compilers}, to
+put it more accurately. Guile defines a tower of languages, starting
+at Scheme and progressively simplifying down to languages that
+resemble the VM instruction set (@pxref{Instruction Set}).
+
+Each language knows how to compile to the next, so each step is simple
+and understandable. Furthermore, this set of languages is not
+hardcoded into Guile, so it is possible for the user to add new
+high-level languages, new passes, or even different compilation
+targets.
+
+Languages are registered in the module, @code{(system base language)}:
+
+@example
+(use-modules (system base language))
+@end example
+
+They are registered with the @code{define-language} form.
+
+@deffn {Scheme Syntax} define-language @
+name title version reader printer @
+[parser=#f] [read-file=#f] [compilers='()] [evaluator=#f]
+Define a language.
+
+This syntax defines a @code{#<language>} object, bound to @var{name}
+in the current environment. In addition, the language will be added to
+the global language set. For example, this is the language definition
+for Scheme:
+
+@example
+(define-language scheme
+ #:title "Guile Scheme"
+ #:version "0.5"
+ #:reader read
+ #:read-file read-file
+ #:compilers `((,ghil . ,compile-ghil))
+ #:evaluator (lambda (x module) (primitive-eval x))
+ #:printer write)
+@end example
+
+In this example, from @code{(language scheme spec)}, @code{read-file}
+reads expressions from a port and wraps them in a @code{begin} block.
+@end deffn
+
+The interesting thing about having languages defined this way is that
+they present a uniform interface to the read-eval-print loop. This
+allows the user to change the current language of the REPL:
+
+@example
+$ guile
+Guile Scheme interpreter 0.5 on Guile 1.9.0
+Copyright (C) 2001-2008 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+scheme@@(guile-user)> ,language ghil
+Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0
+Copyright (C) 2001-2008 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+ghil@@(guile-user)>
+@end example
+
+Languages can be looked up by name, as they were above.
+
+@deffn {Scheme Procedure} lookup-language name
+Looks up a language named @var{name}, autoloading it if necessary.
+
+Languages are autoloaded by looking for a variable named @var{name} in
+a module named @code{(language @var{name} spec)}.
+
+The language object will be returned, or @code{#f} if there does not
+exist a language with that name.
+@end deffn
+
+Defining languages this way allows us to programmatically determine
+the necessary steps for compiling code from one language to another.
+
+@deffn {Scheme Procedure} lookup-compilation-order from to
+Recursively traverses the set of languages to which @var{from} can
+compile, depth-first, and return the first path that can transform
+@var{from} to @var{to}. Returns @code{#f} if no path is found.
+
+This function memoizes its results in a cache that is invalidated by
+subsequent calls to @code{define-language}, so it should be quite
+fast.
+@end deffn
+
+There is a notion of a ``current language'', which is maintained in
+the @code{*current-language*} fluid. This language is normally Scheme,
+and may be rebound by the user. The run-time compilation interfaces
+(@pxref{Read/Load/Eval/Compile}) also allow you to choose other source
+and target languages.
+
+The normal tower of languages when compiling Scheme goes like this:
+
+@itemize
+@item Scheme, which we know and love
+@item Guile High Intermediate Language (GHIL)
+@item Guile Low Intermediate Language (GLIL)
+@item Object code
+@end itemize
+
+Object code may be serialized to disk directly, though it has a cookie
+and version prepended to the front. But when compiling Scheme at
+run time, you want a Scheme value, e.g. a compiled procedure. For this
+reason, so as not to break the abstraction, Guile defines a fake
+language, @code{value}. Compiling to @code{value} loads the object
+code into a procedure, and wakes the sleeping giant.
+
+Perhaps this strangeness can be explained by example:
+@code{compile-file} defaults to compiling to object code, because it
+produces object code that has to live in the barren world outside the
+Guile runtime; but @code{compile} defaults to compiling to
+@code{value}, as its product re-enters the Guile world.
+
+Indeed, the process of compilation can circulate through these
+different worlds indefinitely, as shown by the following quine:
+
+@example
+((lambda (x) ((compile x) x)) '(lambda (x) ((compile x) x)))
+@end example
+
+@node The Scheme Compiler
+@subsection The Scheme Compiler
+
+The job of the Scheme compiler is to expand all macros and to resolve
+all symbols to lexical variables. Its target language, GHIL, is fairly
+close to Scheme itself, so this process is not very complicated.
+
+The Scheme compiler is driven by a table of @dfn{translators},
+declared with the @code{define-scheme-translator} form, defined in the
+module, @code{(language scheme compile-ghil)}.
+
+@deffn {Scheme Syntax} define-scheme-translator head clause1 clause2...
+The best documentation of this form is probably an example. Here is
+the translator for @code{if}:
+
+@example
+(define-scheme-translator 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))))
+@end example
+
+The match syntax is from the @code{pmatch} macro, defined in
+@code{(system base pmatch)}. The result of a clause should be a valid
+GHIL value. If no clause matches, a syntax error is signalled.
+
+In the body of the clauses, the following bindings are introduced:
+@itemize
+@item @code{e}, the current environment
+@item @code{l}, the current source location (or @code{#f})
+@item @code{retrans}, a procedure that may be called to compile
+subexpressions
+@end itemize
+
+Note that translators are looked up by @emph{value}, not by name. That
+is to say, the translator is keyed under the @emph{value} of
+@code{if}, which normally prints as @code{#<primitive-builtin-macro!
+if>}.
+@end deffn
+
+Users can extend the compiler by defining new translators.
+Additionally, some forms can be inlined directly to
+instructions -- @xref{Inlined Scheme Instructions}, for a list. The
+actual inliners are defined in @code{(language scheme inline)}:
+
+@deffn {Scheme Syntax} define-inline head arity1 result1 arity2 result2...
+Defines an inliner for @code{head}. As in
+@code{define-scheme-translator}, inliners are keyed by value and not
+by name.
+
+Expressions are matched on their arities. For example:
+
+@example
+(define-inline eq?
+ (x y) (eq? x y))
+@end example
+
+This inlines calls to the Scheme procedure, @code{eq?}, to the
+instruction @code{eq?}.
+
+A more complicated example would be:
+
+@example
+(define-inline +
+ () 0
+ (x) x
+ (x y) (add x y)
+ (x y . rest) (add x (+ y . rest)))
+@end example
+@end deffn
+
+Compilers take two arguments, an expression and an environment, and
+return two values as well: an expression in the target language, and
+an environment suitable for the target language. The format of the
+environment is language-dependent.
+
+For Scheme, an environment may be one of three things:
+@itemize
+@item @code{#f}, in which case compilation is performed in the context
+of the current module;
+@item a module, which specifies the context of the compilation; or
+@item a @dfn{compile environment}, which specifies lexical variables
+as well.
+@end itemize
+
+The format of a compile environment for scheme is @code{(@var{module}
+@var{lexicals} . @var{externals})}, though users are strongly
+discouraged from constructing these environments themselves. Instead,
+if you need this functionality -- as in GOOPS' dynamic method compiler
+-- capture an environment with @code{compile-time-environment}, then
+pass that environment to @code{compile}.
+
+@deffn {Scheme Procedure} compile-time-environment
+A special function known to the compiler that, when compiled, will
+return a representation of the lexical environment in place at compile
+time. Useful for supporting some forms of dynamic compilation. Returns
+@code{#f} if called from the interpreter.
+@end deffn
+
+@node GHIL
+@subsection GHIL
+
+Guile High Intermediate Language (GHIL) is a structured intermediate
+language that is close in expressive power to Scheme. It is an
+expanded, pre-analyzed Scheme.
+
+GHIL is ``structured'' in the sense that its representation is based
+on records, not S-expressions. This gives a rigidity to the language
+that ensures that compiling to a lower-level language only requires a
+limited set of transformations. Practically speaking, consider the
+GHIL type, @code{<ghil-quote>}, which has fields named @code{env},
+@code{loc}, and @code{exp}. Instances of this type are records created
+via @code{make-ghil-quote}, and whose fields are accessed as
+@code{ghil-quote-env}, @code{ghil-quote-loc}, and
+@code{ghil-quote-exp}. There is also a predicate, @code{ghil-quote?}.
+@xref{Records}, for more information on records.
+
+Expressions of GHIL name their environments explicitly, and all
+variables are referenced by identity in addition to by name.
+@code{(language ghil)} defines a number of routines to deal explicitly
+with variables and environments:
+
+@deftp {Scheme Variable} <ghil-toplevel-env> [table='()]
+A toplevel environment. The @var{table} holds all toplevel variables
+that have been resolved in this environment.
+@end deftp
+@deftp {Scheme Variable} <ghil-env> parent [table='()] [variables='()]
+A lexical environment. @var{parent} will be the enclosing lexical
+environment, or a toplevel environment. @var{table} holds an alist
+mapping symbols to variables bound in this environment, while
+@var{variables} holds a cumulative list of all variables ever defined
+in this environment.
+
+Lexical environments correspond to procedures. Bindings introduced
+e.g. by Scheme's @code{let} add to the bindings in a lexical
+environment. An example of a case in which a variable might be in
+@var{variables} but not in @var{table} would be a variable that is in
+the same procedure, but is out of scope.
+@end deftp
+@deftp {Scheme Variable} <ghil-var> env name kind [index=#f]
+A variable. @var{kind} is one of @code{argument}, @code{local},
+@code{external}, @code{toplevel}, @code{public}, or @code{private};
+see the procedures below for more information. @var{index} is used in
+compilation.
+@end deftp
+
+@deffn {Scheme Procedure} ghil-var-is-bound? env sym
+Recursively look up a variable named @var{sym} in @var{env}, and
+return it or @code{#f} if none is found.
+@end deffn
+@deffn {Scheme Procedure} ghil-var-for-ref! env sym
+Recursively look up a variable named @var{sym} in @var{env}, and
+return it. If the symbol was not bound, return a new toplevel
+variable.
+@end deffn
+@deffn {Scheme Procedure} ghil-var-for-set! env sym
+Like @code{ghil-var-for-ref!}, except that the returned variable will
+be marked as @code{external}. @xref{Variables and the VM}.
+@end deffn
+@deffn {Scheme Procedure} ghil-var-define! toplevel-env sym
+Return an existing or new toplevel variable named @var{sym}.
+@var{toplevel-env} must be a toplevel environment.
+@end deffn
+@deffn {Scheme Procedure} ghil-var-at-module! env modname sym interface?
+Return a variable that will be resolved at run-time with respect to a
+specific module named @var{modname}. If @var{interface?} is true, the
+variable will be of type @code{public}, otherwise @code{private}.
+@end deffn
+@deffn {Scheme Procedure} call-with-ghil-environment env syms func
+Bind @var{syms} to fresh variables within a new lexical environment
+whose parent is @var{env}, and call @var{func} as @code{(@var{func}
+@var{new-env} @var{new-vars})}.
+@end deffn
+@deffn {Scheme Procedure} call-with-ghil-bindings env syms func
+Like @code{call-with-ghil-environment}, except the existing
+environment @var{env} is re-used. For that reason, @var{func} is
+invoked as @code{(@var{func} @var{new-vars})}
+@end deffn
+
+In the aforementioned @code{<ghil-quote>} type, the @var{env} slot
+holds a pointer to the environment in which the expression occurs. The
+@var{loc} slot holds source location information, so that errors
+corresponding to this expression can be mapped back to the initial
+expression in the higher-level language, e.g. Scheme. @xref{Compiled
+Procedures}, for more information on source location objects.
+
+GHIL also has a declarative serialization format, which makes writing
+and reading it a tractable problem for the human mind. Since all GHIL
+language constructs contain @code{env} and @code{loc} pointers, they
+are left out of the serialization. (Serializing @code{env} structures
+would be difficult, as they are often circular.) What is left is the
+type of expression, and the remaining slots defined in the expression
+type.
+
+For example, an S-expression representation of the @code{<ghil-quote>}
+expression would be:
+
+@example
+(quote 3)
+@end example
+
+It's deceptively like Scheme. The general rule is, for a type defined
+as @code{<ghil-@var{foo}> env loc @var{slot1} @var{slot2}...}, the
+S-expression representation will be @code{(@var{foo} @var{slot1}
+@var{slot2}...)}. Users may program with this format directly at the
+REPL:
+
+@example
+scheme@@(guile-user)> ,language ghil
+Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0
+Copyright (C) 2001-2008 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+ghil@@(guile-user)> (call (ref +) (quote 32) (quote 10))
+@result{} 42
+@end example
+
+For convenience, some slots are serialized as rest arguments; those
+are noted below. The other caveat is that variables are serialized as
+their names only, and not their identities.
+
+@deftp {Scheme Variable} <ghil-void> env loc
+The unspecified value.
+@end deftp
+@deftp {Scheme Variable} <ghil-quote> env loc exp
+A quoted expression.
+
+Note that unlike in Scheme, there are no self-quoting expressions; all
+constants must come from @code{quote} expressions.
+@end deftp
+@deftp {Scheme Variable} <ghil-quasiquote> env loc exp
+A quasiquoted expression. The expression is treated as a constant,
+except for embedded @code{unquote} and @code{unquote-splicing} forms.
+@end deftp
+@deftp {Scheme Variable} <ghil-unquote> env loc exp
+Like Scheme's @code{unquote}; only valid within a quasiquote.
+@end deftp
+@deftp {Scheme Variable} <ghil-unquote-splicing> env loc exp
+Like Scheme's @code{unquote-splicing}; only valid within a quasiquote.
+@end deftp
+@deftp {Scheme Variable} <ghil-ref> env loc var
+A variable reference. Note that for purposes of serialization,
+@var{var} is serialized as its name, as a symbol.
+@end deftp
+@deftp {Scheme Variable} <ghil-set> env loc var val
+A variable mutation. @var{var} is serialized as a symbol.
+@end deftp
+@deftp {Scheme Variable} <ghil-define> env loc var val
+A toplevel variable definition. See @code{ghil-var-define!}.
+@end deftp
+@deftp {Scheme Variable} <ghil-if> env loc test then else
+A conditional. Note that @var{else} is not optional.
+@end deftp
+@deftp {Scheme Variable} <ghil-and> env loc . exps
+Like Scheme's @code{and}.
+@end deftp
+@deftp {Scheme Variable} <ghil-or> env loc . exps
+Like Scheme's @code{or}.
+@end deftp
+@deftp {Scheme Variable} <ghil-begin> env loc . body
+Like Scheme's @code{begin}.
+@end deftp
+@deftp {Scheme Variable} <ghil-bind> env loc vars exprs . body
+Like a deconstructed @code{let}: each element of @var{vars} will be
+bound to the corresponding GHIL expression in @var{exprs}.
+
+Note that for purposes of the serialization format, @var{exprs} are
+evaluated before the new bindings are added to the environment. For
+@code{letrec} semantics, there also exists a @code{bindrec} parse
+flavor. This is useful for writing GHIL at the REPL, but the
+serializer does not currently have the cleverness needed to determine
+whether a @code{<ghil-bind>} has @code{let} or @code{letrec}
+semantics, and thus only serializes @code{<ghil-bind>} as @code{bind}.
+@end deftp
+@deftp {Scheme Variable} <ghil-mv-bind> env loc vars rest producer . body
+Like Scheme's @code{receive} -- binds the values returned by
+applying @code{producer}, which should be a thunk, to the
+@code{lambda}-like bindings described by @var{vars} and @var{rest}.
+@end deftp
+@deftp {Scheme Variable} <ghil-lambda> env loc vars rest meta . body
+A closure. @var{vars} is the argument list, serialized as a list of
+symbols. @var{rest} is a boolean, which is @code{#t} iff the last
+argument is a rest argument. @var{meta} is an association list of
+properties. The actual @var{body} should be a list of GHIL
+expressions.
+@end deftp
+@deftp {Scheme Variable} <ghil-call> env loc proc . args
+A procedure call.
+@end deftp
+@deftp {Scheme Variable} <ghil-mv-call> env loc producer consumer
+Like Scheme's @code{call-with-values}.
+@end deftp
+@deftp {Scheme Variable} <ghil-inline> env loc op . args
+An inlined VM instruction. @var{op} should be the instruction name as
+a symbol, and @var{args} should be its arguments, as GHIL expressions.
+@end deftp
+@deftp {Scheme Variable} <ghil-values> env loc . values
+Like Scheme's @code{values}.
+@end deftp
+@deftp {Scheme Variable} <ghil-values*> env loc . values
+@var{values} are as in the Scheme expression, @code{(apply values .
+@var{vals})}.
+@end deftp
+@deftp {Scheme Variable} <ghil-reified-env> env loc
+Produces, at run-time, a reification of the environment at compile
+time. Used in the implementation of Scheme's
+@code{compile-time-environment}.
+@end deftp
+
+GHIL implements a compiler to GLIL that recursively traverses GHIL
+expressions, writing out GLIL expressions into a linear list. The
+compiler also keeps some state as to whether the current expression is
+in tail context, and whether its value will be used in future
+computations. This state allows the compiler not to emit code for
+constant expressions that will not be used (e.g. docstrings), and to
+perform tail calls when in tail position.
+
+Just as the Scheme to GHIL compiler introduced new hidden state---the
+environment---the GHIL to GLIL compiler introduces more state, the
+stack. While not represented explicitly, the stack is present in the
+compilation of each GHIL expression: compiling a GHIL expression
+should leave the run-time value stack in the same state. For example,
+if the intermediate value stack has two elements before evaluating an
+@code{if} expression, it should have two elements after that
+expression.
+
+Interested readers are encouraged to read the implementation in
+@code{(language ghil compile-glil)} for more details.
+
+@node GLIL
+@subsection GLIL
+
+Guile Low Intermediate Language (GLIL) is a structured intermediate
+language whose expressions closely mirror the functionality of Guile's
+VM instruction set.
+
+Its expression types are defined in @code{(language glil)}, and as
+with GHIL, some of its fields parse as rest arguments.
+
+@deftp {Scheme Variable} <glil-program> nargs nrest nlocs nexts meta . body
+A unit of code that at run-time will correspond to a compiled
+procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts}
+collectively define the program's arity; see @ref{Compiled
+Procedures}, for more information. @var{meta} should be an alist of
+properties, as in @code{<ghil-lambda>}. @var{body} is a list of GLIL
+expressions.
+@end deftp
+@deftp {Scheme Variable} <glil-bind> . vars
+An advisory expression that notes a liveness extent for a set of
+variables. @var{vars} is a list of @code{(@var{name} @var{type}
+@var{index})}, where @var{type} should be either @code{argument},
+@code{local}, or @code{external}.
+
+@code{<glil-bind>} expressions end up being serialized as part of a
+program's metadata and do not form part of a program's code path.
+@end deftp
+@deftp {Scheme Variable} <glil-mv-bind> vars rest
+A multiple-value binding of the values on the stack to @var{vars}. Iff
+@var{rest} is true, the last element of @var{vars} will be treated as
+a rest argument.
+
+In addition to pushing a binding annotation on the stack, like
+@code{<glil-bind>}, an expression is emitted at compilation time to
+make sure that there are enough values available to bind. See the
+notes on @code{truncate-values} in @ref{Procedural Instructions}, for
+more information.
+@end deftp
+@deftp {Scheme Variable} <glil-unbind>
+Closes the liveness extent of the most recently encountered
+@code{<glil-bind>} or @code{<glil-mv-bind>} expression. As GLIL
+expressions are compiled, a parallel stack of live bindings is
+maintained; this expression pops off the top element from that stack.
+
+Bindings are written into the program's metadata so that debuggers and
+other tools can determine the set of live local variables at a given
+offset within a VM program.
+@end deftp
+@deftp {Scheme Variable} <glil-source> loc
+Records source information for the preceding expression. @var{loc}
+should be a vector, @code{#(@var{line} @var{column} @var{filename})}.
+@end deftp
+@deftp {Scheme Variable} <glil-void>
+Pushes the unspecified value on the stack.
+@end deftp
+@deftp {Scheme Variable} <glil-const> obj
+Pushes a constant value onto the stack. @var{obj} must be a number,
+string, symbol, keyword, boolean, character, or a pair or vector or
+list thereof, or the empty list.
+@end deftp
+@deftp {Scheme Variable} <glil-argument> op index
+Accesses an argument on the stack. If @var{op} is @code{ref}, the
+argument is pushed onto the stack; if it is @code{set}, the argument
+is set from the top value on the stack, which is popped off.
+@end deftp
+@deftp {Scheme Variable} <glil-local> op index
+Like @code{<glil-argument>}, but for local variables. @xref{Stack
+Layout}, for more information.
+@end deftp
+@deftp {Scheme Variable} <glil-external> op depth index
+Accesses a heap-allocated variable, addressed by @var{depth}, the nth
+enclosing environment, and @var{index}, the variable's position within
+the environment. @var{op} is @code{ref} or @code{set}.
+@end deftp
+@deftp {Scheme Variable} <glil-toplevel> op name
+Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set},
+or @code{define}.
+@end deftp
+@deftp {Scheme Variable} <glil-module> op mod name public?
+Accesses a variable within a specific module. See
+@code{ghil-var-at-module!}, for more information.
+@end deftp
+@deftp {Scheme Variable} <glil-label> label
+Creates a new label. @var{label} can be any Scheme value, and should
+be unique.
+@end deftp
+@deftp {Scheme Variable} <glil-branch> inst label
+Branch to a label. @var{label} should be a @code{<ghil-label>}.
+@code{inst} is a branching instruction: @code{br-if}, @code{br}, etc.
+@end deftp
+@deftp {Scheme Variable} <glil-call> inst nargs
+This expression is probably misnamed, as it does not correspond to
+function calls. @code{<glil-call>} invokes the VM instruction named
+@var{inst}, noting that it is called with @var{nargs} stack arguments.
+The arguments should be pushed on the stack already. What happens to
+the stack afterwards depends on the instruction.
+@end deftp
+@deftp {Scheme Variable} <glil-mv-call> nargs ra
+Performs a multiple-value call. @var{ra} is a @code{<glil-label>}
+corresponding to the multiple-value return address for the call. See
+the notes on @code{mv-call} in @ref{Procedural Instructions}, for more
+information.
+@end deftp
+
+Users may enter in GLIL at the REPL as well, though there is a bit
+more bookkeeping to do. Since GLIL needs the set of variables to be
+declared explicitly in a @code{<glil-program>}, GLIL expressions must
+be wrapped in a thunk that declares the arity of the expression:
+
+@example
+scheme@@(guile-user)> ,language glil
+Guile Lowlevel Intermediate Language (GLIL) interpreter 0.3 on Guile 1.9.0
+Copyright (C) 2001-2008 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+glil@@(guile-user)> (program 0 0 0 0 () (const 3) (call return 0))
+@result{} 3
+@end example
+
+Just as in all of Guile's compilers, an environment is passed to the
+GLIL-to-object code compiler, and one is returned as well, along with
+the object code.
+
+@node Object Code
+@subsection Object Code
+
+Object code is the serialization of the raw instruction stream of a
+program, ready for interpretation by the VM. Procedures related to
+object code are defined in the @code{(system vm objcode)} module.
+
+@deffn {Scheme Procedure} objcode? obj
+@deffnx {C Function} scm_objcode_p (obj)
+Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bytecode->objcode bytecode nlocs nexts
+@deffnx {C Function} scm_bytecode_to_objcode (bytecode, nlocs, nexts)
+Makes a bytecode object from @var{bytecode}, which should be a
+@code{u8vector}. @var{nlocs} and @var{nexts} denote the number of
+stack and heap variables to reserve when this objcode is executed.
+@end deffn
+
+@deffn {Scheme Variable} load-objcode file
+@deffnx {C Function} scm_load_objcode (file)
+Load object code from a file named @var{file}. The file will be mapped
+into memory via @code{mmap}, so this is a very fast operation.
+
+On disk, object code has an eight-byte cookie prepended to it, so that
+we will not execute arbitrary garbage. In addition, two more bytes are
+reserved for @var{nlocs} and @var{nexts}.
+@end deffn
+
+@deffn {Scheme Variable} objcode->u8vector objcode
+@deffnx {C Function} scm_objcode_to_u8vector (objcode)
+Copy object code out to a @code{u8vector} for analysis by Scheme. The
+ten-byte header is included.
+@end deffn
+
+@deffn {Scheme Variable} objcode->program objcode [external='()]
+@deffnx {C Function} scm_objcode_to_program (objcode, external)
+Load up object code into a Scheme program. The resulting program will
+be a thunk that captures closure variables from @var{external}.
+@end deffn
+
+Object code from a file may be disassembled at the REPL via the
+meta-command @code{,disassemble-file}, abbreviated as @code{,xx}.
+Programs may be disassembled via @code{,disassemble}, abbreviated as
+@code{,x}.
+
+Compiling object code to the fake language, @code{value}, is performed
+via loading objcode into a program, then executing that thunk with
+respect to the compilation environment. Normally the environment
+propagates through the compiler transparently, but users may specify
+the compilation environment manually as well:
+
+@deffn {Scheme Procedure} make-objcode-env module externals
+Make an object code environment. @var{module} should be a Scheme
+module, and @var{externals} should be a list of external variables.
+@code{#f} is also a valid object code environment.
+@end deffn
+
+@node Extending the Compiler
+@subsection Extending the Compiler
+
+At this point, we break with the impersonal tone of the rest of the
+manual, and make an intervention. Admit it: if you've read this far
+into the compiler internals manual, you are a junkie. Perhaps a course
+at your university left you unsated, or perhaps you've always harbored
+a sublimated desire to hack the holy of computer science holies: a
+compiler. Well you're in good company, and in a good position. Guile's
+compiler needs your help.
+
+There are many possible avenues for improving Guile's compiler.
+Probably the most important improvement, speed-wise, will be some form
+of native compilation, both just-in-time and ahead-of-time. This could
+be done in many ways. Probably the easiest strategy would be to extend
+the compiled procedure structure to include a pointer to a native code
+vector, and compile from bytecode to native code at run-time after a
+procedure is called a certain number of times.
+
+The name of the game is a profiling-based harvest of the low-hanging
+fruit, running programs of interest under a system-level profiler and
+determining which improvements would give the most bang for the buck.
+There are many well-known efficiency hacks in the literature: Dybvig's
+letrec optimization, individual boxing of heap-allocated values (and
+then store the boxes on the stack directory), optimized case-lambda
+expressions, stack underflow and overflow handlers, etc. Highly
+recommended papers: Dybvig's HOCS, Ghuloum's compiler paper.
+
+The compiler also needs help at the top end, enhancing the Scheme that
+it knows to also understand R6RS, and adding new high-level compilers:
+Emacs Lisp, Lua, JavaScript...
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
-@c essay \input texinfo
-@c essay @c -*-texinfo-*-
-@c essay @c %**start of header
-@c essay @setfilename data-rep.info
-@c essay @settitle Data Representation in Guile
-@c essay @c %**end of header
-
-@c essay @include version.texi
-
-@c essay @dircategory The Algorithmic Language Scheme
-@c essay @direntry
-@c essay * data-rep: (data-rep). Data Representation in Guile --- how to use
-@c essay Guile objects in your C code.
-@c essay @end direntry
-
-@c essay @setchapternewpage off
-
-@c essay @ifinfo
-@c essay Data Representation in Guile
-
-@c essay Copyright (C) 1998, 1999, 2000, 2003, 2006 Free Software Foundation
-
-@c essay Permission is granted to make and distribute verbatim copies of
-@c essay this manual provided the copyright notice and this permission notice
-@c essay are preserved on all copies.
-
-@c essay @ignore
-@c essay Permission is granted to process this file through TeX and print the
-@c essay results, provided the printed document carries copying permission
-@c essay notice identical to this one except for the removal of this paragraph
-@c essay (this paragraph not being relevant to the printed manual).
-@c essay @end ignore
-
-@c essay Permission is granted to copy and distribute modified versions of this
-@c essay manual under the conditions for verbatim copying, provided that the entire
-@c essay resulting derived work is distributed under the terms of a permission
-@c essay notice identical to this one.
-
-@c essay Permission is granted to copy and distribute translations of this manual
-@c essay into another language, under the above conditions for modified versions,
-@c essay except that this permission notice may be stated in a translation approved
-@c essay by the Free Software Foundation.
-@c essay @end ifinfo
-
-@c essay @titlepage
-@c essay @sp 10
-@c essay @comment The title is printed in a large font.
-@c essay @title Data Representation in Guile
-@c essay @subtitle $Id: data-rep.texi,v 1.20 2006-04-16 23:11:15 kryde Exp $
-@c essay @subtitle For use with Guile @value{VERSION}
-@c essay @author Jim Blandy
-@c essay @author Free Software Foundation
-@c essay @author @email{jimb@@red-bean.com}
-@c essay @c The following two commands start the copyright page.
-@c essay @page
-@c essay @vskip 0pt plus 1filll
-@c essay @vskip 0pt plus 1filll
-@c essay Copyright @copyright{} 1998, 2006 Free Software Foundation
-
-@c essay Permission is granted to make and distribute verbatim copies of
-@c essay this manual provided the copyright notice and this permission notice
-@c essay are preserved on all copies.
-
-@c essay Permission is granted to copy and distribute modified versions of this
-@c essay manual under the conditions for verbatim copying, provided that the entire
-@c essay resulting derived work is distributed under the terms of a permission
-@c essay notice identical to this one.
-
-@c essay Permission is granted to copy and distribute translations of this manual
-@c essay into another language, under the above conditions for modified versions,
-@c essay except that this permission notice may be stated in a translation approved
-@c essay by Free Software Foundation.
-@c essay @end titlepage
-
-@c essay @c @smallbook
-@c essay @c @finalout
-@c essay @headings double
-
-
-@c essay @node Top, Data Representation in Scheme, (dir), (dir)
-@c essay @top Data Representation in Guile
-
-@c essay @ifinfo
-@c essay This essay is meant to provide the background necessary to read and
-@c essay write C code that manipulates Scheme values in a way that conforms to
-@c essay libguile's interface. If you would like to write or maintain a
-@c essay Guile-based application in C or C++, this is the first information you
-@c essay need.
-
-@c essay In order to make sense of Guile's @code{SCM_} functions, or read
-@c essay libguile's source code, it's essential to have a good grasp of how Guile
-@c essay actually represents Scheme values. Otherwise, a lot of the code, and
-@c essay the conventions it follows, won't make very much sense.
-
-@c essay We assume you know both C and Scheme, but we do not assume you are
-@c essay familiar with Guile's C interface.
-@c essay @end ifinfo
-
-
-@node Data Representation
-@appendix Data Representation in Guile
-
-@strong{by Jim Blandy}
-
-[Due to the rather non-orthogonal and performance-oriented nature of the
-SCM interface, you need to understand SCM internals *before* you can use
-the SCM API. That's why this chapter comes first.]
-
-[NOTE: this is Jim Blandy's essay almost entirely unmodified. It has to
-be adapted to fit this manual smoothly.]
-
-In order to make sense of Guile's SCM_ functions, or read libguile's
-source code, it's essential to have a good grasp of how Guile actually
-represents Scheme values. Otherwise, a lot of the code, and the
-conventions it follows, won't make very much sense. This essay is meant
-to provide the background necessary to read and write C code that
-manipulates Scheme values in a way that is compatible with libguile.
-
-We assume you know both C and Scheme, but we do not assume you are
-familiar with Guile's implementation.
-
-@menu
-* Data Representation in Scheme:: Why things aren't just totally
- straightforward, in general terms.
-* How Guile does it:: How to write C code that manipulates
- Guile values, with an explanation
- of Guile's garbage collector.
-@end menu
-
@node Data Representation in Scheme
@section Data Representation in Scheme
make some refinements to correct its major weaknesses. However, this is
not a description of the system Guile actually uses. It is only an
illustration of the issues Guile's system must address. We provide all
-the information one needs to work with Guile's data in @ref{How Guile
-does it}.
+the information one needs to work with Guile's data in @ref{The
+Libguile Runtime Environment}.
@menu
more complex than what we've presented above.
-@node How Guile does it
-@section How Guile does it
+@node The Libguile Runtime Environment
+@section The Libguile Runtime Environment
Here we present the specifics of how Guile represents its data. We
don't go into complete detail; an exhaustive description of Guile's
system would be boring, and we do not wish to encourage people to write
code which depends on its details anyway. We do, however, present
-everything one need know to use Guile's data.
-
-This section is in limbo. It used to document the 'low-level' C API
-of Guile that was used both by clients of libguile and by libguile
-itself.
+everything one need know to use Guile's data. It is assumed that the
+reader understands the concepts laid out in @ref{Data Representation
+in Scheme}.
-In the future, clients should only need to look into the sections
-@ref{Programming in C} and @ref{API Reference}. This section will in
-the end only contain stuff about the internals of Guile.
+FIXME: much of this is outdated as of 1.8, we don't provide many of
+these macros any more. Also here we're missing sections about the
+evaluator implementation, which is interesting, and notes about tail
+recursion between scheme and c.
@menu
* General Rules::
@code{SCM} value is done using the @code{PTR2SCM} macro.
@c (FIXME:: this name should be changed)
-@deftypefn Macro (scm_t_cell *) SCM2PTR (SCM @var{x})
+@deftypefn Macro {scm_t_cell *} SCM2PTR (SCM @var{x})
Extract and return the heap cell pointer from a non-immediate @code{SCM}
object @var{x}.
@end deftypefn
* Guile Modules::
+* Guile Implementation::
+
* Autoconf Support::
Appendices
-* Data Representation:: All the details.
* GNU Free Documentation License:: The license of this manual.
Indices
into existing programs.
There is also a pedagogical yet detailed explanation of how the data
-representation of Guile is implemented, @xref{Data Representation}.
+representation of Guile is implemented, see @ref{Data Representation in
+Scheme} and @ref{The Libguile Runtime Environment}.
+
You don't need to know the details given there to use Guile from C,
but they are useful when you want to modify Guile itself or when you
are just curious about how it is all done.
* Binding Constructs:: Definitions and variable bindings.
* Control Mechanisms:: Controlling the flow of program execution.
* Input and Output:: Ports, reading and writing.
-* Read/Load/Eval:: Reading and evaluating Scheme code.
+* Read/Load/Eval/Compile:: Reading and evaluating Scheme code.
* Memory Management:: Memory management and garbage collection.
* Objects:: Low level object orientation support.
* Modules:: Designing reusable code libraries.
@include scsh.texi
@include scheme-debugging.texi
-@include autoconf.texi
+@node Guile Implementation
+@chapter Guile Implementation
+
+At some point, after one has been programming in Scheme for some time,
+another level of Scheme comes into view: its implementation. Knowledge
+of how Scheme can be implemented turns out to be necessary to become
+an expert hacker. As Peter Norvig notes in his retrospective on
+PAIP@footnote{PAIP is the common abbreviation for @cite{Paradigms of
+Artificial Intelligence Programming}, an old but still useful text on
+Lisp. Norvig's retrospective sums up the lessons of PAIP, and can be
+found at @uref{http://norvig.com/Lisp-retro.html}.}, ``The expert Lisp
+programmer eventually develops a good `efficiency model'.''
+
+By this Norvig means that over time, the Lisp hacker eventually
+develops an understanding of how much her code ``costs'' in terms of
+space and time.
+
+This chapter describes Guile as an implementation of Scheme: its
+history, how it represents and evaluates its data, and its compiler.
+This knowledge can help you to make that step from being one who is
+merely familiar with Scheme to being a real hacker.
+@menu
+* History:: A brief history of Guile.
+* Data Representation in Scheme:: Why things aren't just totally
+ straightforward, in general terms.
+* The Libguile Runtime Environment:: Low-level details on Guile's C
+ runtime library.
+* A Virtual Machine for Guile:: How compiled procedures work.
+* Compiling to the Virtual Machine:: Not as hard as you might think.
+@end menu
+
+@include history.texi
@include data-rep.texi
+@include vm.texi
+@include compiler.texi
+
+@include autoconf.texi
+
@include fdl.texi
@iftex
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2008
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node History
+@section A Brief History of Guile
+
+Guile is an artifact of historical processes, both as code and as a
+community of hackers. It is sometimes useful to know this history when
+hacking the source code, to know about past decisions and future
+directions.
+
+Of course, the real history of Guile is written by the hackers hacking
+and not the writers writing, so we round up the section with a note on
+current status and future directions.
+
+@menu
+* The Emacs Thesis::
+* Early Days::
+* A Scheme of Many Maintainers::
+* A Timeline of Selected Guile Releases::
+* Status::
+@end menu
+
+@node The Emacs Thesis
+@subsection The Emacs Thesis
+
+The story of Guile is the story of bringing the development experience
+of Emacs to the mass of programs on a GNU system.
+
+Emacs, when it was first created in its GNU form in 1984, was a new
+take on the problem of ``how to make a program''. The Emacs thesis is
+that it is delightful to create composite programs based on an
+orthogonal kernel written in a low-level language together with a
+powerful, high-level extension language.
+
+Extension languages foster extensible programs, programs which adapt
+readily to different users and to changing times. Proof of this can be
+seen in Emacs' current and continued existence, spanning more than a
+quarter-century.
+
+Besides providing for modification of a program by others, extension
+languages are good for @emph{intension} as well. Programs built in
+``the Emacs way'' are pleasurable and easy for their authors to flesh
+out with the features that they need.
+
+After the Emacs experience was appreciated more widely, a number of
+hackers started to consider how to spread this experience to the rest
+of the GNU system. It was clear that the easiest way to Emacsify a
+program would be to embed a shared language implementation into it.
+
+@node Early Days
+@subsection Early Days
+
+Tom Lord was the first to fully concentrate his efforts on an
+embeddable language runtime, which he named ``GEL'', the GNU Extension
+Language.
+
+GEL was the product of converting SCM, Aubrey Jaffer's implementation
+of Scheme, into something more appropriate to embedding as a library.
+(SCM was itself based on an implementation by George Carrette, SIOD.)
+
+Lord managed to convince Richard Stallman to dub GEL the official
+extension language for the GNU project. It was a natural fit, given
+that Scheme was a cleaner, more modern Lisp than Emacs Lisp. Part of
+the argument was that eventually when GEL became more capable, it
+could gain the ability to execute other languages, especially Emacs
+Lisp.
+
+Due to a naming conflict with another programming language, Jim Blandy
+suggested a new name for GEL: ``Guile''. Besides being a recursive
+acroymn, ``Guile'' craftily follows the naming of its ancestors,
+``Planner'', ``Conniver'', and ``Schemer''. (The latter was truncated
+to ``Scheme'' due to a 6-character file name limit on an old operating
+system.) Finally, ``Guile'' suggests ``guy-ell'', or ``Guy L.
+Steele'', who, together with Gerald Sussman, originally discovered
+Scheme.
+
+Around the same time that Guile (then GEL) was readying itself for
+public release, another extension language was gaining in popularity,
+Tcl. Many developers found advantages in Tcl because of its shell-like
+syntax and its well-developed graphical widgets library, Tk. Also, at
+the time there was a large marketing push promoting Tcl as a
+``universal extension language''.
+
+Richard Stallman, as the primary author of GNU Emacs, had a particular
+vision of what extension languages should be, and Tcl did not seem to
+him to be as capable as Emacs Lisp. He posted a criticism to the
+comp.lang.tcl newsgroup, sparking one of the internet's legendary
+flamewars. As part of these discussions, retrospectively dubbed the
+``Tcl Wars'', he announced the Free Software Foundation's intent to
+promote Guile as the extension language for the GNU project.
+
+It is a common misconception that Guile was created as a reaction to
+Tcl. While it is true that the public announcement of Guile happened
+at the same time as the ``Tcl wars'', Guile was created out of a
+condition that existed outside the polemic. Indeed, the need for a
+powerful language to bridge the gap between extension of existing
+applications and a more fully dynamic programming environment is still
+with us today.
+
+@node A Scheme of Many Maintainers
+@subsection A Scheme of Many Mantainers
+
+Surveying the field, it seems that Scheme implementations correspond
+with their maintainers on an N-to-1 relationship. That is to say, that
+those people that implement Schemes might do so on a number of
+occasions, but that the lifetime of a given Scheme is tied to the
+maintainership of one individual.
+
+Guile is atypical in this regard.
+
+Tom Lord maintaned Guile for its first year and a half or so,
+corresponding to the end of 1994 through the middle of 1996. The
+releases made in this time constitute an arc from SCM as a standalone
+program to Guile as a reusable, embeddable library, but passing
+through a explosion of features: embedded Tcl and Tk, a toolchain for
+compiling and disassembling Java, addition of a C-like syntax,
+creation of a module system, and a start at a rich POSIX interface.
+
+Only some of those features remain in Guile. There were ongoing
+tensions between providing a small, embeddable language, and one which
+had all of the features (e.g. a graphical toolkit) that a modern Emacs
+might need. In the end, as Guile gained in uptake, the development
+team decided to focus on depth, documentation and orthogonality rather
+than on breadth. This has been the focus of Guile ever since, although
+there is a wide range of third-party libraries for Guile.
+
+Jim Blandy presided over that period of stabilization, in the three
+years until the end of 1999, when he too moved on to other projects.
+Since then, Guile has had a group maintainership. The first group was
+Maciej Stachowiak, Mikael Djurfeldt, and Marius Vollmer, with Vollmer
+staying on the longest. By late 2007, Vollmer had mostly moved on to
+other things, so Neil Jerram and Ludovic Courtès stepped up to take on
+the primary maintenance responsibility.
+
+Of course, a large part of the actual work on Guile has come from
+other contributors too numerous to mention, but without whom the world
+would be a poorer place.
+
+@node A Timeline of Selected Guile Releases
+@subsection A Timeline of Selected Guile Releases
+
+@table @asis
+@item guile-i --- 4 February 1995
+SCM, turned into a library.
+
+@item guile-ii --- 6 April 1995
+A low-level module system was added. Tcl/Tk support was added,
+allowing extension of Scheme by Tcl or vice versa. POSIX support was
+improved, and there was an experimental stab at Java integration.
+
+@item guile-iii --- 18 August 1995
+The C-like syntax, ctax, was improved, but mostly this release
+featured a start at the task of breaking Guile into pieces.
+
+@item 1.0 --- 5 January 1997
+@code{#f} was distinguished from @code{'()}. User-level, cooperative
+multi-threading was added. Source-level debugging became more useful,
+and programmer's and user's manuals were begun. The module system
+gained a high-level interface, which is still used today in more or
+less the same form.
+
+@item 1.1 --- 16 May 1997
+@itemx 1.2 --- 24 June 1997
+Support for Tcl/Tk and ctax were split off as separate packages, and
+have remained there since. Guile became more compatible with SCSH, and
+more useful as a UNIX scripting language. Libguile can now be built as
+a shared library, and third-party extensions written in C became
+loadable via dynamic linking.
+
+@item 1.3.0 --- 19 October 1998
+Command-line editing became much more pleasant through the use of the
+readline library. The initial support for internationalization via
+multi-byte strings was removed, and has yet to be added back, though
+UTF-8 hacks are common. Modules gained the ability to have custom
+expanders, which is still used for syntax-case macros. Initial Emacs
+Lisp support landed, ports gained better support for file descriptors,
+and fluids were added.
+
+@item 1.3.2 --- 20 August 1999
+@itemx 1.3.4 --- 25 September 1999
+@itemx 1.4 --- 21 June 2000
+A long list of lispy features were added: hooks, Common Lisp's
+@code{format}, optional and keyword procedure arguments,
+@code{getopt-long}, sorting, random numbers, and many other fixes and
+enhancements. Guile now has an interactive debugger, interactive help,
+and gives better backtraces.
+
+@item 1.6 --- 6 September 2002
+Guile gained support for the R5RS standard, and added a number of SRFI
+modules. The module system was expanded with programmatic support for
+identifier selection and renaming. The GOOPS object system was merged
+into Guile core.
+
+@item 1.8 --- 20 February 2006
+Guile's arbitrary-precision arithmetic switched to use the GMP
+library, and added support for exact rationals. Guile's embedded
+user-space threading was removed in favor of POSIX pre-emptive
+threads, providing true multiprocessing. Gettext support was added,
+and Guile's C API was cleaned up and orthogonalized in a massive way.
+
+@item 2.0 --- thus far, only unstable snapshots available
+A virtual machine was added to Guile, along with the associated
+compiler and toolchain. Support for internationalization was added.
+Running Guile instances became controllable and debuggable from within
+Emacs, via GDS, which was also backported to 1.8.5. An SRFI-18
+interface to multithreading was added, including thread cancellation.
+@end table
+
+@node Status
+@subsection Status, or: Your Help Needed
+
+Guile has achieved much of what it set out to achieve, but there is
+much remaining to do.
+
+There is still the old problem of bringing existing applications into
+a more Emacs-like experience. Guile has had some successes in this
+respect, but still most applications in the GNU system are without
+Guile integration.
+
+Getting Guile to those applications takes an investment, the
+``hacktivation energy'' needed to wire Guile into a program that only
+pays off once it is good enough to enable new kinds of behavior. This
+would be a great way for new hackers to contribute: take an
+application that you use and that you know well, think of something
+that it can't yet do, and figure out a way to integrate Guile and
+implement that task in Guile.
+
+With time, perhaps this exposure can reverse itself, whereby programs
+can run under Guile instead of vice versa, eventually resulting in the
+Emacsification of the entire GNU system. Indeed, this is the reason
+for the naming of the many Guile modules that live in the @code{ice-9}
+namespace, a nod to the fictional substance in Kurt Vonnegut's
+novel, Cat's Cradle, capable of acting as a seed crystal to
+crystallize the mass of software.
+
+Implicit to this whole discussion is the idea that dynamic languages
+are somehow better than languages like C. While languages like C have
+their place, Guile's take on this question is that yes, Scheme is more
+expressive than C, and more fun to write. This realization carries an
+imperative with it to write as much code in Scheme as possible rather
+than in other languages.
+
+These days it is possible to write extensible applications almost
+entirely from high-level languages, through byte-code and native
+compilation, speed gains in the underlying hardware, and foreign call
+interfaces in the high-level language. Smalltalk systems are like
+this, as are Common Lisp-based systems. While there already are a
+number of pure-Guile applications out there, users still need to drop
+down to C for some tasks: interfacing to system libraries that don't
+have prebuilt Guile interfaces, and for some tasks requiring high
+performance.
+
+The addition of the virtual machine in Guile 2.0, together with the
+compiler infrastructure, should go a long way to addressing the speed
+issues. But there is much optimization to be done. Interested
+contributors will find lots of delightful low-hanging fruit, from
+simple profile-driven optimization to hacking a just-in-time compiler
+from VM bytecode to native code.
+
+Still, even with an all-Guile application, sometimes you want to
+provide an opportunity for users to extend your program from a
+language with a syntax that is closer to C, or to Python. Another
+interesting idea to consider is compiling e.g. Python to Guile. It's
+not that far-fetched of an idea: see for example IronPython or JRuby.
+
+And then there's Emacs itself. Though there is a somewhat-working
+Emacs Lisp translator for Guile, it cannot yet execute all of Emacs
+Lisp. A serious integration of Guile with Emacs would replace the
+Elisp virtual machine with Guile, and provide the necessary C shims so
+that Guile could emulate Emacs' C API. This would give lots of
+exciting things to Emacs: native threads, a real object system, more
+sophisticated types, cleaner syntax, and access to all of the Guile
+extensions.
+
+Finally, there is another axis of crystallization, the axis between
+different Scheme implementations. Guile does not yet support the
+latest Scheme standard, R6RS, and should do so. Like all standards,
+R6RS is imperfect, but supporting it will allow more code to run on
+Guile without modification, and will allow Guile hackers to produce
+code compatible with other schemes. Help in this regard would be much
+appreciated.
Also, computing with @code{SCM} is not necessarily inefficient. Small
integers will be encoded directly in the @code{SCM} value, for example,
-and do not need any additional memory on the heap. See @ref{Data
-Representation} to find out the details.
+and do not need any additional memory on the heap. See @ref{The
+Libguile Runtime Environment} to find out the details.
Some special @code{SCM} values are available to C code without needing
to convert them from C values:
@code{scm_t_bits}. This is an unsigned integral type of sufficient
size to hold all information that is directly contained in a
@code{SCM} value. The @code{scm_t_bits} type is used internally by
-Guile to do all the bit twiddling explained in @ref{Data
-Representation}, but you will encounter it occasionally in low-level
+Guile to do all the bit twiddling explained in @ref{The Libguile
+Runtime Environment}, but you will encounter it occasionally in low-level
user code as well.
room for one @code{void*} or @code{SCM} value plus 16 bits. The
reason for this is that smobs are directly implemented by using the
low-level, two-word cells of Guile that are also used to implement
-pairs, for example. (@pxref{Data Representation} for the details.)
-One word of the two-word cells is used for @code{SCM_SMOB_DATA} (or
-@code{SCM_SMOB_OBJECT}), the other contains the 16-bit type tag and
-the 16 extra bits.
+pairs, for example. (@pxref{The Libguile Runtime Environment} for the
+details.) One word of the two-word cells is used for
+@code{SCM_SMOB_DATA} (or @code{SCM_SMOB_OBJECT}), the other contains
+the 16-bit type tag and the 16 extra bits.
In addition to the fundamental two-word cells, Guile also has
four-word cells, which are appropriately called @dfn{double cells}.
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2008,2009
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node A Virtual Machine for Guile
+@section A Virtual Machine for Guile
+
+Guile has both an interpreter and a compiler. To a user, the
+difference is largely transparent---interpreted and compiled
+procedures can call each other as they please.
+
+The difference is that the compiler creates and interprets bytecode
+for a custom virtual machine, instead of interpreting the
+S-expressions directly. Running compiled code is faster than running
+interpreted code.
+
+The virtual machine that does the bytecode interpretation is a part of
+Guile itself. This section describes the nature of Guile's virtual
+machine.
+
+@menu
+* Why a VM?::
+* VM Concepts::
+* Stack Layout::
+* Variables and the VM::
+* VM Programs::
+* Instruction Set::
+@end menu
+
+@node Why a VM?
+@subsection Why a VM?
+
+@cindex interpreter
+@cindex evaluator
+For a long time, Guile only had an interpreter, called the
+@dfn{evaluator}. Guile's evaluator operates directly on the
+S-expression representation of Scheme source code.
+
+But while the evaluator is highly optimized and hand-tuned, and
+contains some extensive speed trickery (@pxref{Memoization}), it still
+performs many needless computations during the course of evaluating an
+expression. For example, application of a function to arguments
+needlessly conses up the arguments in a list. Evaluation of an
+expression always has to figure out what the car of the expression is
+-- a procedure, a memoized form, or something else. All values have to
+be allocated on the heap. Et cetera.
+
+The solution to this problem is to compile the higher-level language,
+Scheme, into a lower-level language for which all of the checks and
+dispatching have already been done---the code is instead stripped to
+the bare minimum needed to ``do the job''.
+
+The question becomes then, what low-level language to choose? There
+are many options. We could compile to native code directly, but that
+poses portability problems for Guile, as it is a highly cross-platform
+project.
+
+So we want the performance gains that compilation provides, but we
+also want to maintain the portability benefits of a single code path.
+The obvious solution is to compile to a virtual machine that is
+present on all Guile installations.
+
+The easiest (and most fun) way to depend on a virtual machine is to
+implement the virtual machine within Guile itself. This way the
+virtual machine provides what Scheme needs (tail calls, multiple
+values, @code{call/cc}) and can provide optimized inline instructions
+for Guile (@code{cons}, @code{struct-ref}, etc.).
+
+So this is what Guile does. The rest of this section describes that VM
+that Guile implements, and the compiled procedures that run on it.
+
+Note that this decision to implement a bytecode compiler does not
+preclude native compilation. We can compile from bytecode to native
+code at runtime, or even do ahead of time compilation. More
+possibilities are discussed in @ref{Extending the Compiler}.
+
+@node VM Concepts
+@subsection VM Concepts
+
+A virtual machine (VM) is a Scheme object. Users may create virtual
+machines using the standard procedures described later in this manual,
+but that is usually unnecessary, as Guile ensures that there is one
+virtual machine per thread. When a VM-compiled procedure is run, Guile
+looks up the virtual machine for the current thread and executes the
+procedure using that VM.
+
+Guile's virtual machine is a stack machine---that is, it has few
+registers, and the instructions defined in the VM operate by pushing
+and popping values from a stack.
+
+Stack memory is exclusive to the virtual machine that owns it. In
+addition to their stacks, virtual machines also have access to the
+global memory (modules, global bindings, etc) that is shared among
+other parts of Guile, including other VMs.
+
+A VM has generic instructions, such as those to reference local
+variables, and instructions designed to support Guile's languages --
+mathematical instructions that support the entire numerical tower, an
+inlined implementation of @code{cons}, etc.
+
+The registers that a VM has are as follows:
+
+@itemize
+@item ip - Instruction pointer
+@item sp - Stack pointer
+@item fp - Frame pointer
+@end itemize
+
+In other architectures, the instruction pointer is sometimes called
+the ``program counter'' (pc). This set of registers is pretty typical
+for stack machines; their exact meanings in the context of Guile's VM
+is described in the next section.
+
+A virtual machine executes by loading a compiled procedure, and
+executing the object code associated with that procedure. Of course,
+that procedure may call other procedures, tail-call others, ad
+infinitum---indeed, within a guile whose modules have all been
+compiled to object code, one might never leave the virtual machine.
+
+@c wingo: I wish the following were true, but currently we just use
+@c the one engine. This kind of thing is possible tho.
+
+@c A VM may have one of three engines: reckless, regular, or debugging.
+@c Reckless engine is fastest but dangerous. Regular engine is normally
+@c fail-safe and reasonably fast. Debugging engine is safest and
+@c functional but very slow.
+
+@node Stack Layout
+@subsection Stack Layout
+
+While not strictly necessary to understand how to work with the VM, it
+is instructive and sometimes entertaining to consider the struture of
+the VM stack.
+
+Logically speaking, a VM stack is composed of ``frames''. Each frame
+corresponds to the application of one compiled procedure, and contains
+storage space for arguments, local variables, intermediate values, and
+some bookkeeping information (such as what to do after the frame
+computes its value).
+
+While the compiler is free to do whatever it wants to, as long as the
+semantics of a computation are preserved, in practice every time you
+call a function, a new frame is created. (The notable exception of
+course is the tail call case, @pxref{Tail Calls}.)
+
+Within a frame, you have the data associated with the function
+application itself, which is of a fixed size, and the stack space for
+intermediate values. Sometimes only the former is referred to as the
+``frame'', and the latter is the ``stack'', although all pending
+application frames can have some intermediate computations interleaved
+on the stack.
+
+The structure of the fixed part of an application frame is as follows:
+
+@example
+ Stack
+ | | <- fp + bp->nargs + bp->nlocs + 4
+ +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
+ | Return address |
+ | MV return address|
+ | Dynamic 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)
+ | |
+@end example
+
+In the above drawing, the stack grows upward. The intermediate values
+stored in the application of this frame are stored above
+@code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the
+@code{struct scm_program*} data associated with the program at
+@code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the
+compiled procedure, which will be discussed later.
+
+The individual fields of the frame are as follows:
+
+@table @asis
+@item Return address
+The @code{ip} that was in effect before this program was applied. When
+we return from this activation frame, we will jump back to this
+@code{ip}.
+
+@item MV return address
+The @code{ip} to return to if this application returns multiple
+values. For continuations that only accept one value, this value will
+be @code{NULL}; for others, it will be an @code{ip} that points to a
+multiple-value return address in the calling code. That code will
+expect the top value on the stack to be an integer---the number of
+values being returned---and that below that integer there are the
+values being returned.
+
+@item Dynamic link
+This is the @code{fp} in effect before this program was applied. In
+effect, this and the return address are the registers that are always
+``saved''.
+
+@item External link
+This field is a reference to the list of heap-allocated variables
+associated with this frame. For a discussion of heap versus stack
+allocation, @xref{Variables and the VM}.
+
+@item Local variable @var{n}
+Lambda-local variables that are allocated on the stack are all
+allocated as part of the frame. This makes access to non-captured,
+non-mutated variables very cheap.
+
+@item Argument @var{n}
+The calling convention of the VM requires arguments of a function
+application to be pushed on the stack, and here they are. Normally
+references to arguments dispatch to these locations on the stack.
+However if an argument has to be stored on the heap, it will be copied
+from its initial value here onto a location in the heap, and
+thereafter only referenced on the heap.
+
+@item Program
+This is the program being applied. For more information on how
+programs are implemented, @xref{VM Programs}.
+@end table
+
+@node Variables and the VM
+@subsection Variables and the VM
+
+Let's think about the following Scheme code as an example:
+
+@example
+ (define (foo a)
+ (lambda (b) (list foo a b)))
+@end example
+
+Within the lambda expression, "foo" is a top-level variable, "a" is a
+lexically captured variable, and "b" is a local variable.
+
+That is to say: @code{b} may safely be allocated on the stack, as
+there is no enclosed procedure that references it, nor is it ever
+mutated.
+
+@code{a}, on the other hand, is referenced by an enclosed procedure,
+that of the lambda. Thus it must be allocated on the heap, as it may
+(and will) outlive the dynamic extent of the invocation of @code{foo}.
+
+@code{foo} is a toplevel variable, as mandated by Scheme's semantics:
+
+@example
+ (define proc (foo 'bar)) ; assuming prev. definition of @code{foo}
+ (define foo 42) ; redefinition
+ (proc 'baz)
+ @result{} (42 bar baz)
+@end example
+
+Note that variables that are mutated (via @code{set!}) must be
+allocated on the heap, even if they are local variables. This is
+because any called subprocedure might capture the continuation, which
+would need to capture locations instead of values. Thus perhaps
+counterintuitively, what would seem ``closer to the metal'', viz
+@code{set!}, actually forces heap allocation instead of stack
+allocation.
+
+@node VM Programs
+@subsection Compiled Procedures are VM Programs
+
+By default, when you enter in expressions at Guile's REPL, they are
+first compiled to VM object code, then that VM object code is executed
+to produce a value. If the expression evaluates to a procedure, the
+result of this process is a compiled procedure.
+
+A compiled procedure is a compound object, consisting of its bytecode,
+a reference to any captured lexical variables, an object array, and
+some metadata such as the procedure's arity, name, and documentation.
+You can pick apart these pieces with the accessors in @code{(system vm
+program)}. @xref{Compiled Procedures}, for a full API reference.
+
+@cindex object table
+The object array of a compiled procedure, also known as the
+@dfn{object table}, holds all Scheme objects whose values are known
+not to change across invocations of the procedure: constant strings,
+symbols, etc. The object table of a program is initialized right
+before a program is loaded with @code{load-program}.
+@xref{Loading Instructions}, for more information.
+
+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, toplevel bindings only need to be looked up once.
+Thereafter, references to the corresponding toplevel variables from
+within the program are then performed via the @code{toplevel-ref}
+instruction, which uses the object vector, and are almost as fast as
+local variable references.
+
+We can see how these concepts tie together by disassembling the
+@code{foo} function to see what is going on:
+
+@smallexample
+scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
+scheme@@(guile-user)> ,x foo
+Disassembly of #<program foo (a)>:
+
+Bytecode:
+
+ 0 (local-ref 0) ;; `a' (arg)
+ 2 (external-set 0) ;; `a' (arg)
+ 4 (object-ref 0) ;; #<program #(0 28 #f) (b)>
+ 6 (make-closure) at (unknown file):0:16
+ 7 (return)
+
+----------------------------------------
+Disassembly of #<program #(0 28 #f) (b)>:
+
+Bytecode:
+
+ 0 (toplevel-ref 0) ;; `list'
+ 2 (toplevel-ref 1) ;; `foo'
+ 4 (external-ref 0) ;; (closure variable)
+ 6 (local-ref 0) ;; `b' (arg)
+ 8 (goto/args 3) at (unknown file):0:28
+@end smallexample
+
+At @code{ip} 0 and 2, we do the copy from argument to heap for
+@code{a}. @code{Ip} 4 loads up the compiled lambda, and then at
+@code{ip} 6 we make a closure---binding code (from the compiled
+lambda) with data (the heap-allocated variables). Finally we return
+the closure.
+
+The second stanza disassembles the compiled lambda. Toplevel variables
+are resolved relative to the module that was current when the
+procedure was created. This lookup occurs lazily, at the first time
+the variable is actually referenced, and the location of the lookup is
+cached so that future references are very cheap. @xref{Environment
+Control Instructions}, for more details.
+
+Then we see a reference to an external variable, corresponding to
+@code{a}. The disassembler doesn't have enough information to give a
+name to that variable, so it just marks it as being a ``closure
+variable''. Finally we see the reference to @code{b}, then a tail call
+(@code{goto/args}) with three arguments.
+
+@node Instruction Set
+@subsection Instruction Set
+
+There are about 100 instructions in Guile's virtual machine. These
+instructions represent atomic units of a program's execution. Ideally,
+they perform one task without conditional branches, then dispatch to
+the next instruction in the stream.
+
+Instructions themselves are one byte long. Some instructions take
+parameters, which follow the instruction byte in the instruction
+stream.
+
+Sometimes the compiler can figure out that it is compiling a special
+case that can be run more efficiently. So, for example, while Guile
+offers a generic test-and-branch instruction, it also offers specific
+instructions for special cases, so that the following cases all have
+their own test-and-branch instructions:
+
+@example
+(if pred then else)
+(if (not pred) then else)
+(if (null? l) then else)
+(if (not (null? l)) then else)
+@end example
+
+In addition, some Scheme primitives have their own inline
+implementations, e.g. @code{cons}.
+
+So Guile's instruction set is a @emph{complete} instruction set, in
+that it provides the instructions that are suited to the problem, and
+is not concerned with making a minimal, orthogonal set of
+instructions. More instructions may be added over time.
+
+@menu
+* Environment Control Instructions::
+* Branch Instructions::
+* Loading Instructions::
+* Procedural Instructions::
+* Data Control Instructions::
+* Miscellaneous Instructions::
+* Inlined Scheme Instructions::
+* Inlined Mathematical Instructions::
+@end menu
+
+@node Environment Control Instructions
+@subsubsection Environment Control Instructions
+
+These instructions access and mutate the environment of a compiled
+procedure---the local bindings, the ``external'' bindings, and the
+toplevel bindings.
+
+@deffn Instruction local-ref index
+Push onto the stack the value of the local variable located at
+@var{index} within the current stack frame.
+
+Note that arguments and local variables are all in one block. Thus the
+first argument, if any, is at index 0, and local bindings follow the
+arguments.
+@end deffn
+
+@deffn Instruction local-set index
+Pop the Scheme object located on top of the stack and make it the new
+value of the local variable located at @var{index} within the current
+stack frame.
+@end deffn
+
+@deffn Instruction external-ref index
+Push the value of the closure variable located at position
+@var{index} within the program's list of external variables.
+@end deffn
+
+@deffn Instruction external-set index
+Pop the Scheme object located on top of the stack and make it the new
+value of the closure variable located at @var{index} within the
+program's list of external variables.
+@end deffn
+
+The external variable lookup algorithm should probably be made more
+efficient in the future via addressing by frame and index. Currently,
+external variables are all consed onto a list, which results in O(N)
+lookup time.
+
+@deffn Instruction externals
+Pushes the current list of external variables onto the stack. This
+instruction is used in the implementation of
+@code{compile-time-environment}. @xref{The Scheme Compiler}.
+@end deffn
+
+@deffn Instruction toplevel-ref index
+Push the value of the toplevel binding whose location is stored in at
+position @var{index} in the object table.
+
+Initially, a cell in the object table that is used by
+@code{toplevel-ref} is initialized to one of two forms. The normal
+case is that the cell holds a symbol, whose binding will be looked up
+relative to the module that was current when the current program was
+created.
+
+Alternately, the lookup may be performed relative to a particular
+module, determined at compile-time (e.g. via @code{@@} or
+@code{@@@@}). In that case, the cell in the object table holds a list:
+@code{(@var{modname} @var{sym} @var{interface?})}. The symbol
+@var{sym} will be looked up in the module named @var{modname} (a list
+of symbols). The lookup will be performed against the module's public
+interface, unless @var{interface?} is @code{#f}, which it is for
+example when compiling @code{@@@@}.
+
+In any case, if the symbol is unbound, an error is signalled.
+Otherwise the initial form is replaced with the looked-up variable, an
+in-place mutation of the object table. This mechanism provides for
+lazy variable resolution, and an important cached fast-path once the
+variable has been successfully resolved.
+
+This instruction pushes the value of the variable onto the stack.
+@end deffn
+
+@deffn Instruction toplevel-ref index
+Pop a value off the stack, and set it as the value of the toplevel
+variable stored at @var{index} in the object table. If the variable
+has not yet been looked up, we do the lookup as in
+@code{toplevel-ref}.
+@end deffn
+
+@deffn Instruction link-now
+Pop a value, @var{x}, from the stack. Look up the binding for @var{x},
+according to the rules for @code{toplevel-ref}, and push that variable
+on the stack. If the lookup fails, an error will be signalled.
+
+This instruction is mostly used when loading programs, because it can
+do toplevel variable lookups without an object vector.
+@end deffn
+
+@deffn Instruction 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 Instruction variable-set
+Pop off two objects from the stack, a variable and a value, and set
+the variable to the value.
+@end deffn
+
+@deffn Instruction object-ref n
+Push @var{n}th value from the current program's object vector.
+@end deffn
+
+@node Branch Instructions
+@subsubsection Branch Instructions
+
+All the conditional branch instructions described below work in the
+same way:
+
+@itemize
+@item They pop off the Scheme object located on the stack and use it as
+the branch condition;
+@item If the condition is true, then the instruction pointer is
+increased by the offset passed as an argument to the branch
+instruction;
+@item Program execution proceeds with the next instruction (that is,
+the one to which the instruction pointer points).
+@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 Instruction br offset
+Jump to @var{offset}.
+@end deffn
+
+@deffn Instruction br-if offset
+Jump to @var{offset} if the condition on the stack is not false.
+@end deffn
+
+@deffn Instruction br-if-not offset
+Jump to @var{offset} if the condition on the stack is false.
+@end deffn
+
+@deffn Instruction 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 Instruction br-if-not-eq offset
+Same as @var{br-if-eq} for non-@code{eq?} objects.
+@end deffn
+
+@deffn Instruction br-if-null offset
+Jump to @var{offset} if the object on the stack is @code{'()}.
+@end deffn
+
+@deffn Instruction br-if-not-null offset
+Jump to @var{offset} if the object on the stack is not @code{'()}.
+@end deffn
+
+
+@node Loading Instructions
+@subsubsection Loading Instructions
+
+In addition to VM instructions, an instruction stream may contain
+variable-length data embedded within it. This data is always preceded
+by special loading instructions, which interpret the data and advance
+the instruction pointer to the next VM instruction.
+
+All of these loading instructions have a @code{length} parameter,
+indicating the size of the embedded data, in bytes. The length itself
+may be encoded in 1, 2, or 4 bytes.
+
+@deffn Instruction load-integer length
+@deffnx Instruction load-unsigned-integer length
+Load a 32-bit integer (respectively unsigned integer) from the
+instruction stream.
+@end deffn
+@deffn Instruction load-number length
+Load an arbitrary number from the instruction stream. The number is
+embedded in the stream as a string.
+@end deffn
+@deffn Instruction load-string length
+Load a string from the instruction stream.
+@end deffn
+@deffn Instruction load-symbol length
+Load a symbol from the instruction stream.
+@end deffn
+@deffn Instruction load-keyword length
+Load a keyword from the instruction stream.
+@end deffn
+
+@deffn Instruction define length
+Load a symbol from the instruction stream, and look up its binding in
+the current toplevel environment, creating the binding if necessary.
+Push the variable corresponding to the binding.
+@end deffn
+
+@deffn Instruction load-program length
+Load bytecode from the instruction stream, and push a compiled
+procedure. This instruction pops the following values from the stack:
+
+@itemize
+@item Optionally, a thunk, which when called should return metadata
+associated with this program---for example its name, the names of its
+arguments, its documentation string, debugging information, etc.
+
+Normally, this thunk its itself a compiled procedure (with no
+metadata). Metadata is represented this way so that the initial load
+of a procedure is fast: the VM just mmap's the thunk and goes. The
+symbols and pairs associated with the metadata are only created if the
+user asks for them.
+
+For information on the format of the thunk's return value,
+@xref{Compiled Procedures}.
+@item Optionally, the program's object table, as a vector.
+
+A program that does not reference toplevel bindings and does not use
+@code{object-ref} does not need an object table.
+@item Finally, either one immediate integer or four immediate integers
+representing the arity of the program.
+
+In the four-fixnum case, the values are 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}).
+
+The common single-fixnum case represents all of these values within a
+16-bit bitmask.
+@end itemize
+
+The resulting compiled procedure will not have any ``external''
+variables captured, so it will be loaded only once but may be used
+many times to create closures.
+@end deffn
+
+Finally, while this instruction is not strictly a ``loading''
+instruction, it's useful to wind up the @code{load-program} discussion
+here:
+
+@deffn Instruction make-closure
+Pop the program object from the stack, capture the current set of
+``external'' variables, and assign those external variables to a copy
+of the program. Push the new program object, which shares state with
+the original program. Also captures the current module.
+@end deffn
+
+@node Procedural Instructions
+@subsubsection Procedural Instructions
+
+@deffn Instruction return
+Free the program's frame, returning the top value from the stack to
+the current continuation. (The stack should have exactly one value on
+it.)
+
+Specifically, the @code{sp} is decremented to one below the current
+@code{fp}, the @code{ip} is reset to the current return address, the
+@code{fp} is reset to the value of the current dynamic link, and then
+the top item on the stack (formerly the procedure being applied) is
+set to the returned value.
+@end deffn
+
+@deffn Instruction call nargs
+Call the procedure located at @code{sp[-nargs]} with the @var{nargs}
+arguments located from @code{sp[0]} to @code{sp[-nargs + 1]}.
+
+For non-compiled procedures (continuations, primitives, and
+interpreted procedures), @code{call} will pop the procedure and
+arguments off the stack, and push the result of calling
+@code{scm_apply}.
+
+For compiled procedures, this instruction sets up a new stack frame,
+as described in @ref{Stack Layout}, and then dispatches to the first
+instruction in the called procedure, relying on the called procedure
+to return one value to the newly-created continuation.
+@end deffn
+
+@deffn Instruction goto/args nargs
+Like @code{call}, but reusing the current continuation. This
+instruction implements tail calling as required by RnRS.
+
+For compiled procedures, that means that @code{goto/args} reuses the
+current frame instead of building a new one. The @code{goto/*}
+instruction family is named as it is because tail calls are equivalent
+to @code{goto}, along with relabeled variables.
+
+For non-VM procedures, the result is the same, but the current VM
+invocation remains on the C stack. True tail calls are not currently
+possible between compiled and non-compiled procedures.
+@end deffn
+
+@deffn Instruction apply nargs
+@deffnx Instruction goto/apply nargs
+Like @code{call} and @code{goto/args}, except that the top item on the
+stack must be a list. The elements of that list are then pushed on the
+stack and treated as additional arguments, replacing the list itself,
+then the procedure is invoked as usual.
+@end deffn
+
+@deffn Instruction call/nargs
+@deffnx Instruction goto/nargs
+These are like @code{call} and @code{goto/args}, except they take the
+number of arguments from the stack instead of the instruction stream.
+These instructions are used in the implementation of multiple value
+returns, where the actual number of values is pushed on the stack.
+@end deffn
+
+@deffn Instruction call/cc
+@deffnx Instruction goto/cc
+Capture the current continuation, and then call (or tail-call) the
+procedure on the top of the stack, with the continuation as the
+argument.
+
+Both the VM continuation and the C continuation are captured.
+@end deffn
+
+@deffn Instruction mv-call nargs offset
+Like @code{call}, except that a multiple-value continuation is created
+in addition to a single-value continuation.
+
+The offset (a two-byte value) is an offset within the instruction
+stream; the multiple-value return address in the new frame
+(@pxref{Stack Layout}) will be set to the normal return address plus
+this offset. Instructions at that offset will expect the top value of
+the stack to be the number of values, and below that values
+themselves, pushed separately.
+@end deffn
+
+@deffn Instruction return/values nvalues
+Return the top @var{nvalues} to the current continuation.
+
+If the current continuation is a multiple-value continuation,
+@code{return/values} pushes the number of values on the stack, then
+returns as in @code{return}, but to the multiple-value return address.
+
+Otherwise if the current continuation accepts only one value, i.e. the
+multiple-value return address is @code{NULL}, then we assume the user
+only wants one value, and we give them the first one. If there are no
+values, an error is signaled.
+@end deffn
+
+@deffn Instruction return/values* nvalues
+Like a combination of @code{apply} and @code{return/values}, in which
+the top value on the stack is interpreted as a list of additional
+values. This is an optimization for the common @code{(apply values
+...)} case.
+@end deffn
+
+@deffn Instruction truncate-values nbinds nrest
+Used in multiple-value continuations, this instruction takes the
+values that are on the stack (including the number-of-value marker)
+and truncates them for a binding construct.
+
+For example, a call to @code{(receive (x y . z) (foo) ...)} would,
+logically speaking, pop off the values returned from @code{(foo)} and
+push them as three values, corresponding to @code{x}, @code{y}, and
+@code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would
+be 1 (to indicate that one of the bindings was a rest arguments).
+
+Signals an error if there is an insufficient number of values.
+@end deffn
+
+@node Data Control Instructions
+@subsubsection Data Control Instructions
+
+These instructions push simple immediate values onto the stack, or
+manipulate lists and vectors on the stack.
+
+@deffn Instruction make-int8 value
+Push @var{value}, an 8-bit integer, onto the stack.
+@end deffn
+
+@deffn Instruction make-int8:0
+Push the immediate value @code{0} onto the stack.
+@end deffn
+
+@deffn Instruction make-int8:1
+Push the immediate value @code{1} onto the stack.
+@end deffn
+
+@deffn Instruction make-int16 value
+Push @var{value}, a 16-bit integer, onto the stack.
+@end deffn
+
+@deffn Instruction make-false
+Push @code{#f} onto the stack.
+@end deffn
+
+@deffn Instruction make-true
+Push @code{#t} onto the stack.
+@end deffn
+
+@deffn Instruction make-eol
+Push @code{'()} onto the stack.
+@end deffn
+
+@deffn Instruction make-char8 value
+Push @var{value}, an 8-bit character, onto the stack.
+@end deffn
+
+@deffn Instruction list n
+Pops off the top @var{n} values off of the stack, consing them up into
+a list, then pushes that list on the stack. What was the topmost value
+will be the last element in the list.
+@end deffn
+
+@deffn Instruction vector n
+Create and fill a vector with the top @var{n} values from the stack,
+popping off those values and pushing on the resulting vector.
+@end deffn
+
+@deffn Instruction mark
+Pushes a special value onto the stack that other stack instructions
+like @code{list-mark} can use.
+@end deffn
+
+@deffn Instruction list-mark
+Create a list from values from the stack, as in @code{list}, but
+instead of knowing beforehand how many there will be, keep going until
+we see a @code{mark} value.
+@end deffn
+
+@deffn Instruction cons-mark
+As the scheme procedure @code{cons*} is to the scheme procedure
+@code{list}, so the instruction @code{cons-mark} is to the instruction
+@code{list-mark}.
+@end deffn
+
+@deffn Instruction vector-mark
+Like @code{list-mark}, but makes a vector instead of a list.
+@end deffn
+
+@deffn Instruction list-break
+The opposite of @code{list}: pops a value, which should be a list, and
+pushes its elements on the stack.
+@end deffn
+
+@node Miscellaneous Instructions
+@subsubsection Miscellaneous Instructions
+
+@deffn Instruction nop
+Does nothing!
+@end deffn
+
+@deffn Instruction halt
+Exits the VM, returning a SCM value. Normally, this instruction is
+only part of the ``bootstrap program'', a program run when a virtual
+machine is first entered; compiled Scheme procedures will not contain
+this instruction.
+
+If multiple values have been returned, the SCM value will be a
+multiple-values object (@pxref{Multiple Values}).
+@end deffn
+
+@deffn Instruction break
+Does nothing, but invokes the break hook.
+@end deffn
+
+@deffn Instruction drop
+Pops off the top value from the stack, throwing it away.
+@end deffn
+
+@deffn Instruction dup
+Re-pushes the top value onto the stack.
+@end deffn
+
+@deffn Instruction void
+Pushes ``the unspecified value'' onto the stack.
+@end deffn
+
+@node Inlined Scheme Instructions
+@subsubsection Inlined Scheme Instructions
+
+The Scheme compiler can recognize the application of standard Scheme
+procedures, or unbound variables that look like they are bound to
+standard Scheme procedures. It tries to inline these small operations
+to avoid the overhead of creating new stack frames.
+
+Since most of these operations are historically implemented as C
+primitives, not inlining them would entail constantly calling out from
+the VM to the interpreter, which has some costs---registers must be
+saved, the interpreter has to dispatch, called procedures have to do
+much typechecking, etc. It's much more efficient to inline these
+operations in the virtual machine itself.
+
+All of these instructions pop their arguments from the stack and push
+their results, and take no parameters from the instruction stream.
+Thus, unlike in the previous sections, these instruction definitions
+show stack parameters instead of parameters from the instruction
+stream.
+
+@deffn Instruction not x
+@deffnx Instruction not-not x
+@deffnx Instruction eq? x y
+@deffnx Instruction not-eq? x y
+@deffnx Instruction null?
+@deffnx Instruction not-null?
+@deffnx Instruction eqv? x y
+@deffnx Instruction equal? x y
+@deffnx Instruction pair? x y
+@deffnx Instruction list? x y
+@deffnx Instruction set-car! pair x
+@deffnx Instruction set-cdr! pair x
+@deffnx Instruction slot-ref struct n
+@deffnx Instruction slot-set struct n x
+@deffnx Instruction cons x
+@deffnx Instruction car x
+@deffnx Instruction cdr x
+Inlined implementations of their Scheme equivalents.
+@end deffn
+
+Note that @code{caddr} and friends compile to a series of @code{car}
+and @code{cdr} instructions.
+
+@node Inlined Mathematical Instructions
+@subsubsection Inlined Mathematical Instructions
+
+Inlining mathematical operations has the obvious advantage of handling
+fixnums without function calls or allocations. The trick, of course,
+is knowing when the result of an operation will be a fixnum, and there
+might be a couple bugs here.
+
+More instructions could be added here over time.
+
+As in the previous section, the definitions below show stack
+parameters instead of instruction stream parameters.
+
+@deffn Instruction add x y
+@deffnx Instruction sub x y
+@deffnx Instruction mul x y
+@deffnx Instruction div x y
+@deffnx Instruction quo x y
+@deffnx Instruction rem x y
+@deffnx Instruction mod x y
+@deffnx Instruction ee? x y
+@deffnx Instruction lt? x y
+@deffnx Instruction gt? x y
+@deffnx Instruction le? x y
+@deffnx Instruction ge? x y
+Inlined implementations of the corresponding mathematical operations.
+@end deffn
--- /dev/null
+% texinfo.tex -- TeX macros to handle Texinfo files.
+%
+% Load plain if necessary, i.e., if running under initex.
+\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
+%
+\def\texinfoversion{2007-12-02.17}
+%
+% Copyright (C) 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995, 2007,
+% 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+% 2007 Free Software Foundation, Inc.
+%
+% This texinfo.tex file is free software: you can redistribute it and/or
+% modify it under the terms of the GNU General Public License as
+% published by the Free Software Foundation, either version 3 of the
+% License, or (at your option) any later version.
+%
+% This texinfo.tex file is distributed in the hope that it will be
+% useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+% of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+% General Public License for more details.
+%
+% You should have received a copy of the GNU General Public License
+% along with this program. If not, see <http://www.gnu.org/licenses/>.
+%
+% As a special exception, when this file is read by TeX when processing
+% a Texinfo source document, you may use the result without
+% restriction. (This has been our intent since Texinfo was invented.)
+%
+% Please try the latest version of texinfo.tex before submitting bug
+% reports; you can get the latest version from:
+% http://www.gnu.org/software/texinfo/ (the Texinfo home page), or
+% ftp://tug.org/tex/texinfo.tex
+% (and all CTAN mirrors, see http://www.ctan.org).
+% The texinfo.tex in any given distribution could well be out
+% of date, so if that's what you're using, please check.
+%
+% Send bug reports to bug-texinfo@gnu.org. Please include including a
+% complete document in each bug report with which we can reproduce the
+% problem. Patches are, of course, greatly appreciated.
+%
+% To process a Texinfo manual with TeX, it's most reliable to use the
+% texi2dvi shell script that comes with the distribution. For a simple
+% manual foo.texi, however, you can get away with this:
+% tex foo.texi
+% texindex foo.??
+% tex foo.texi
+% tex foo.texi
+% dvips foo.dvi -o # or whatever; this makes foo.ps.
+% The extra TeX runs get the cross-reference information correct.
+% Sometimes one run after texindex suffices, and sometimes you need more
+% than two; texi2dvi does it as many times as necessary.
+%
+% It is possible to adapt texinfo.tex for other languages, to some
+% extent. You can get the existing language-specific files from the
+% full Texinfo distribution.
+%
+% The GNU Texinfo home page is http://www.gnu.org/software/texinfo.
+
+
+\message{Loading texinfo [version \texinfoversion]:}
+
+% If in a .fmt file, print the version number
+% and turn on active characters that we couldn't do earlier because
+% they might have appeared in the input file name.
+\everyjob{\message{[Texinfo version \texinfoversion]}%
+ \catcode`+=\active \catcode`\_=\active}
+
+
+\chardef\other=12
+
+% We never want plain's \outer definition of \+ in Texinfo.
+% For @tex, we can use \tabalign.
+\let\+ = \relax
+
+% Save some plain tex macros whose names we will redefine.
+\let\ptexb=\b
+\let\ptexbullet=\bullet
+\let\ptexc=\c
+\let\ptexcomma=\,
+\let\ptexdot=\.
+\let\ptexdots=\dots
+\let\ptexend=\end
+\let\ptexequiv=\equiv
+\let\ptexexclam=\!
+\let\ptexfootnote=\footnote
+\let\ptexgtr=>
+\let\ptexhat=^
+\let\ptexi=\i
+\let\ptexindent=\indent
+\let\ptexinsert=\insert
+\let\ptexlbrace=\{
+\let\ptexless=<
+\let\ptexnewwrite\newwrite
+\let\ptexnoindent=\noindent
+\let\ptexplus=+
+\let\ptexrbrace=\}
+\let\ptexslash=\/
+\let\ptexstar=\*
+\let\ptext=\t
+
+% If this character appears in an error message or help string, it
+% starts a new line in the output.
+\newlinechar = `^^J
+
+% Use TeX 3.0's \inputlineno to get the line number, for better error
+% messages, but if we're using an old version of TeX, don't do anything.
+%
+\ifx\inputlineno\thisisundefined
+ \let\linenumber = \empty % Pre-3.0.
+\else
+ \def\linenumber{l.\the\inputlineno:\space}
+\fi
+
+% Set up fixed words for English if not already set.
+\ifx\putwordAppendix\undefined \gdef\putwordAppendix{Appendix}\fi
+\ifx\putwordChapter\undefined \gdef\putwordChapter{Chapter}\fi
+\ifx\putwordfile\undefined \gdef\putwordfile{file}\fi
+\ifx\putwordin\undefined \gdef\putwordin{in}\fi
+\ifx\putwordIndexIsEmpty\undefined \gdef\putwordIndexIsEmpty{(Index is empty)}\fi
+\ifx\putwordIndexNonexistent\undefined \gdef\putwordIndexNonexistent{(Index is nonexistent)}\fi
+\ifx\putwordInfo\undefined \gdef\putwordInfo{Info}\fi
+\ifx\putwordInstanceVariableof\undefined \gdef\putwordInstanceVariableof{Instance Variable of}\fi
+\ifx\putwordMethodon\undefined \gdef\putwordMethodon{Method on}\fi
+\ifx\putwordNoTitle\undefined \gdef\putwordNoTitle{No Title}\fi
+\ifx\putwordof\undefined \gdef\putwordof{of}\fi
+\ifx\putwordon\undefined \gdef\putwordon{on}\fi
+\ifx\putwordpage\undefined \gdef\putwordpage{page}\fi
+\ifx\putwordsection\undefined \gdef\putwordsection{section}\fi
+\ifx\putwordSection\undefined \gdef\putwordSection{Section}\fi
+\ifx\putwordsee\undefined \gdef\putwordsee{see}\fi
+\ifx\putwordSee\undefined \gdef\putwordSee{See}\fi
+\ifx\putwordShortTOC\undefined \gdef\putwordShortTOC{Short Contents}\fi
+\ifx\putwordTOC\undefined \gdef\putwordTOC{Table of Contents}\fi
+%
+\ifx\putwordMJan\undefined \gdef\putwordMJan{January}\fi
+\ifx\putwordMFeb\undefined \gdef\putwordMFeb{February}\fi
+\ifx\putwordMMar\undefined \gdef\putwordMMar{March}\fi
+\ifx\putwordMApr\undefined \gdef\putwordMApr{April}\fi
+\ifx\putwordMMay\undefined \gdef\putwordMMay{May}\fi
+\ifx\putwordMJun\undefined \gdef\putwordMJun{June}\fi
+\ifx\putwordMJul\undefined \gdef\putwordMJul{July}\fi
+\ifx\putwordMAug\undefined \gdef\putwordMAug{August}\fi
+\ifx\putwordMSep\undefined \gdef\putwordMSep{September}\fi
+\ifx\putwordMOct\undefined \gdef\putwordMOct{October}\fi
+\ifx\putwordMNov\undefined \gdef\putwordMNov{November}\fi
+\ifx\putwordMDec\undefined \gdef\putwordMDec{December}\fi
+%
+\ifx\putwordDefmac\undefined \gdef\putwordDefmac{Macro}\fi
+\ifx\putwordDefspec\undefined \gdef\putwordDefspec{Special Form}\fi
+\ifx\putwordDefvar\undefined \gdef\putwordDefvar{Variable}\fi
+\ifx\putwordDefopt\undefined \gdef\putwordDefopt{User Option}\fi
+\ifx\putwordDeffunc\undefined \gdef\putwordDeffunc{Function}\fi
+
+% Since the category of space is not known, we have to be careful.
+\chardef\spacecat = 10
+\def\spaceisspace{\catcode`\ =\spacecat}
+
+% sometimes characters are active, so we need control sequences.
+\chardef\colonChar = `\:
+\chardef\commaChar = `\,
+\chardef\dashChar = `\-
+\chardef\dotChar = `\.
+\chardef\exclamChar= `\!
+\chardef\lquoteChar= `\`
+\chardef\questChar = `\?
+\chardef\rquoteChar= `\'
+\chardef\semiChar = `\;
+\chardef\underChar = `\_
+
+% Ignore a token.
+%
+\def\gobble#1{}
+
+% The following is used inside several \edef's.
+\def\makecsname#1{\expandafter\noexpand\csname#1\endcsname}
+
+% Hyphenation fixes.
+\hyphenation{
+ Flor-i-da Ghost-script Ghost-view Mac-OS Post-Script
+ ap-pen-dix bit-map bit-maps
+ data-base data-bases eshell fall-ing half-way long-est man-u-script
+ man-u-scripts mini-buf-fer mini-buf-fers over-view par-a-digm
+ par-a-digms rath-er rec-tan-gu-lar ro-bot-ics se-vere-ly set-up spa-ces
+ spell-ing spell-ings
+ stand-alone strong-est time-stamp time-stamps which-ever white-space
+ wide-spread wrap-around
+}
+
+% Margin to add to right of even pages, to left of odd pages.
+\newdimen\bindingoffset
+\newdimen\normaloffset
+\newdimen\pagewidth \newdimen\pageheight
+
+% For a final copy, take out the rectangles
+% that mark overfull boxes (in case you have decided
+% that the text looks ok even though it passes the margin).
+%
+\def\finalout{\overfullrule=0pt}
+
+% @| inserts a changebar to the left of the current line. It should
+% surround any changed text. This approach does *not* work if the
+% change spans more than two lines of output. To handle that, we would
+% have adopt a much more difficult approach (putting marks into the main
+% vertical list for the beginning and end of each change).
+%
+\def\|{%
+ % \vadjust can only be used in horizontal mode.
+ \leavevmode
+ %
+ % Append this vertical mode material after the current line in the output.
+ \vadjust{%
+ % We want to insert a rule with the height and depth of the current
+ % leading; that is exactly what \strutbox is supposed to record.
+ \vskip-\baselineskip
+ %
+ % \vadjust-items are inserted at the left edge of the type. So
+ % the \llap here moves out into the left-hand margin.
+ \llap{%
+ %
+ % For a thicker or thinner bar, change the `1pt'.
+ \vrule height\baselineskip width1pt
+ %
+ % This is the space between the bar and the text.
+ \hskip 12pt
+ }%
+ }%
+}
+
+% Sometimes it is convenient to have everything in the transcript file
+% and nothing on the terminal. We don't just call \tracingall here,
+% since that produces some useless output on the terminal. We also make
+% some effort to order the tracing commands to reduce output in the log
+% file; cf. trace.sty in LaTeX.
+%
+\def\gloggingall{\begingroup \globaldefs = 1 \loggingall \endgroup}%
+\def\loggingall{%
+ \tracingstats2
+ \tracingpages1
+ \tracinglostchars2 % 2 gives us more in etex
+ \tracingparagraphs1
+ \tracingoutput1
+ \tracingmacros2
+ \tracingrestores1
+ \showboxbreadth\maxdimen \showboxdepth\maxdimen
+ \ifx\eTeXversion\undefined\else % etex gives us more logging
+ \tracingscantokens1
+ \tracingifs1
+ \tracinggroups1
+ \tracingnesting2
+ \tracingassigns1
+ \fi
+ \tracingcommands3 % 3 gives us more in etex
+ \errorcontextlines16
+}%
+
+% add check for \lastpenalty to plain's definitions. If the last thing
+% we did was a \nobreak, we don't want to insert more space.
+%
+\def\smallbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\smallskipamount
+ \removelastskip\penalty-50\smallskip\fi\fi}
+\def\medbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\medskipamount
+ \removelastskip\penalty-100\medskip\fi\fi}
+\def\bigbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\bigskipamount
+ \removelastskip\penalty-200\bigskip\fi\fi}
+
+% For @cropmarks command.
+% Do @cropmarks to get crop marks.
+%
+\newif\ifcropmarks
+\let\cropmarks = \cropmarkstrue
+%
+% Dimensions to add cropmarks at corners.
+% Added by P. A. MacKay, 12 Nov. 1986
+%
+\newdimen\outerhsize \newdimen\outervsize % set by the paper size routines
+\newdimen\cornerlong \cornerlong=1pc
+\newdimen\cornerthick \cornerthick=.3pt
+\newdimen\topandbottommargin \topandbottommargin=.75in
+
+% Output a mark which sets \thischapter, \thissection and \thiscolor.
+% We dump everything together because we only have one kind of mark.
+% This works because we only use \botmark / \topmark, not \firstmark.
+%
+% A mark contains a subexpression of the \ifcase ... \fi construct.
+% \get*marks macros below extract the needed part using \ifcase.
+%
+% Another complication is to let the user choose whether \thischapter
+% (\thissection) refers to the chapter (section) in effect at the top
+% of a page, or that at the bottom of a page. The solution is
+% described on page 260 of The TeXbook. It involves outputting two
+% marks for the sectioning macros, one before the section break, and
+% one after. I won't pretend I can describe this better than DEK...
+\def\domark{%
+ \toks0=\expandafter{\lastchapterdefs}%
+ \toks2=\expandafter{\lastsectiondefs}%
+ \toks4=\expandafter{\prevchapterdefs}%
+ \toks6=\expandafter{\prevsectiondefs}%
+ \toks8=\expandafter{\lastcolordefs}%
+ \mark{%
+ \the\toks0 \the\toks2
+ \noexpand\or \the\toks4 \the\toks6
+ \noexpand\else \the\toks8
+ }%
+}
+% \topmark doesn't work for the very first chapter (after the title
+% page or the contents), so we use \firstmark there -- this gets us
+% the mark with the chapter defs, unless the user sneaks in, e.g.,
+% @setcolor (or @url, or @link, etc.) between @contents and the very
+% first @chapter.
+\def\gettopheadingmarks{%
+ \ifcase0\topmark\fi
+ \ifx\thischapter\empty \ifcase0\firstmark\fi \fi
+}
+\def\getbottomheadingmarks{\ifcase1\botmark\fi}
+\def\getcolormarks{\ifcase2\topmark\fi}
+
+% Avoid "undefined control sequence" errors.
+\def\lastchapterdefs{}
+\def\lastsectiondefs{}
+\def\prevchapterdefs{}
+\def\prevsectiondefs{}
+\def\lastcolordefs{}
+
+% Main output routine.
+\chardef\PAGE = 255
+\output = {\onepageout{\pagecontents\PAGE}}
+
+\newbox\headlinebox
+\newbox\footlinebox
+
+% \onepageout takes a vbox as an argument. Note that \pagecontents
+% does insertions, but you have to call it yourself.
+\def\onepageout#1{%
+ \ifcropmarks \hoffset=0pt \else \hoffset=\normaloffset \fi
+ %
+ \ifodd\pageno \advance\hoffset by \bindingoffset
+ \else \advance\hoffset by -\bindingoffset\fi
+ %
+ % Do this outside of the \shipout so @code etc. will be expanded in
+ % the headline as they should be, not taken literally (outputting ''code).
+ \ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi
+ \setbox\headlinebox = \vbox{\let\hsize=\pagewidth \makeheadline}%
+ \ifodd\pageno \getoddfootingmarks \else \getevenfootingmarks \fi
+ \setbox\footlinebox = \vbox{\let\hsize=\pagewidth \makefootline}%
+ %
+ {%
+ % Have to do this stuff outside the \shipout because we want it to
+ % take effect in \write's, yet the group defined by the \vbox ends
+ % before the \shipout runs.
+ %
+ \indexdummies % don't expand commands in the output.
+ \normalturnoffactive % \ in index entries must not stay \, e.g., if
+ % the page break happens to be in the middle of an example.
+ % We don't want .vr (or whatever) entries like this:
+ % \entry{{\tt \indexbackslash }acronym}{32}{\code {\acronym}}
+ % "\acronym" won't work when it's read back in;
+ % it needs to be
+ % {\code {{\tt \backslashcurfont }acronym}
+ \shipout\vbox{%
+ % Do this early so pdf references go to the beginning of the page.
+ \ifpdfmakepagedest \pdfdest name{\the\pageno} xyz\fi
+ %
+ \ifcropmarks \vbox to \outervsize\bgroup
+ \hsize = \outerhsize
+ \vskip-\topandbottommargin
+ \vtop to0pt{%
+ \line{\ewtop\hfil\ewtop}%
+ \nointerlineskip
+ \line{%
+ \vbox{\moveleft\cornerthick\nstop}%
+ \hfill
+ \vbox{\moveright\cornerthick\nstop}%
+ }%
+ \vss}%
+ \vskip\topandbottommargin
+ \line\bgroup
+ \hfil % center the page within the outer (page) hsize.
+ \ifodd\pageno\hskip\bindingoffset\fi
+ \vbox\bgroup
+ \fi
+ %
+ \unvbox\headlinebox
+ \pagebody{#1}%
+ \ifdim\ht\footlinebox > 0pt
+ % Only leave this space if the footline is nonempty.
+ % (We lessened \vsize for it in \oddfootingyyy.)
+ % The \baselineskip=24pt in plain's \makefootline has no effect.
+ \vskip 24pt
+ \unvbox\footlinebox
+ \fi
+ %
+ \ifcropmarks
+ \egroup % end of \vbox\bgroup
+ \hfil\egroup % end of (centering) \line\bgroup
+ \vskip\topandbottommargin plus1fill minus1fill
+ \boxmaxdepth = \cornerthick
+ \vbox to0pt{\vss
+ \line{%
+ \vbox{\moveleft\cornerthick\nsbot}%
+ \hfill
+ \vbox{\moveright\cornerthick\nsbot}%
+ }%
+ \nointerlineskip
+ \line{\ewbot\hfil\ewbot}%
+ }%
+ \egroup % \vbox from first cropmarks clause
+ \fi
+ }% end of \shipout\vbox
+ }% end of group with \indexdummies
+ \advancepageno
+ \ifnum\outputpenalty>-20000 \else\dosupereject\fi
+}
+
+\newinsert\margin \dimen\margin=\maxdimen
+
+\def\pagebody#1{\vbox to\pageheight{\boxmaxdepth=\maxdepth #1}}
+{\catcode`\@ =11
+\gdef\pagecontents#1{\ifvoid\topins\else\unvbox\topins\fi
+% marginal hacks, juha@viisa.uucp (Juha Takala)
+\ifvoid\margin\else % marginal info is present
+ \rlap{\kern\hsize\vbox to\z@{\kern1pt\box\margin \vss}}\fi
+\dimen@=\dp#1\relax \unvbox#1\relax
+\ifvoid\footins\else\vskip\skip\footins\footnoterule \unvbox\footins\fi
+\ifr@ggedbottom \kern-\dimen@ \vfil \fi}
+}
+
+% Here are the rules for the cropmarks. Note that they are
+% offset so that the space between them is truly \outerhsize or \outervsize
+% (P. A. MacKay, 12 November, 1986)
+%
+\def\ewtop{\vrule height\cornerthick depth0pt width\cornerlong}
+\def\nstop{\vbox
+ {\hrule height\cornerthick depth\cornerlong width\cornerthick}}
+\def\ewbot{\vrule height0pt depth\cornerthick width\cornerlong}
+\def\nsbot{\vbox
+ {\hrule height\cornerlong depth\cornerthick width\cornerthick}}
+
+% Parse an argument, then pass it to #1. The argument is the rest of
+% the input line (except we remove a trailing comment). #1 should be a
+% macro which expects an ordinary undelimited TeX argument.
+%
+\def\parsearg{\parseargusing{}}
+\def\parseargusing#1#2{%
+ \def\argtorun{#2}%
+ \begingroup
+ \obeylines
+ \spaceisspace
+ #1%
+ \parseargline\empty% Insert the \empty token, see \finishparsearg below.
+}
+
+{\obeylines %
+ \gdef\parseargline#1^^M{%
+ \endgroup % End of the group started in \parsearg.
+ \argremovecomment #1\comment\ArgTerm%
+ }%
+}
+
+% First remove any @comment, then any @c comment.
+\def\argremovecomment#1\comment#2\ArgTerm{\argremovec #1\c\ArgTerm}
+\def\argremovec#1\c#2\ArgTerm{\argcheckspaces#1\^^M\ArgTerm}
+
+% Each occurence of `\^^M' or `<space>\^^M' is replaced by a single space.
+%
+% \argremovec might leave us with trailing space, e.g.,
+% @end itemize @c foo
+% This space token undergoes the same procedure and is eventually removed
+% by \finishparsearg.
+%
+\def\argcheckspaces#1\^^M{\argcheckspacesX#1\^^M \^^M}
+\def\argcheckspacesX#1 \^^M{\argcheckspacesY#1\^^M}
+\def\argcheckspacesY#1\^^M#2\^^M#3\ArgTerm{%
+ \def\temp{#3}%
+ \ifx\temp\empty
+ % Do not use \next, perhaps the caller of \parsearg uses it; reuse \temp:
+ \let\temp\finishparsearg
+ \else
+ \let\temp\argcheckspaces
+ \fi
+ % Put the space token in:
+ \temp#1 #3\ArgTerm
+}
+
+% If a _delimited_ argument is enclosed in braces, they get stripped; so
+% to get _exactly_ the rest of the line, we had to prevent such situation.
+% We prepended an \empty token at the very beginning and we expand it now,
+% just before passing the control to \argtorun.
+% (Similarily, we have to think about #3 of \argcheckspacesY above: it is
+% either the null string, or it ends with \^^M---thus there is no danger
+% that a pair of braces would be stripped.
+%
+% But first, we have to remove the trailing space token.
+%
+\def\finishparsearg#1 \ArgTerm{\expandafter\argtorun\expandafter{#1}}
+
+% \parseargdef\foo{...}
+% is roughly equivalent to
+% \def\foo{\parsearg\Xfoo}
+% \def\Xfoo#1{...}
+%
+% Actually, I use \csname\string\foo\endcsname, ie. \\foo, as it is my
+% favourite TeX trick. --kasal, 16nov03
+
+\def\parseargdef#1{%
+ \expandafter \doparseargdef \csname\string#1\endcsname #1%
+}
+\def\doparseargdef#1#2{%
+ \def#2{\parsearg#1}%
+ \def#1##1%
+}
+
+% Several utility definitions with active space:
+{
+ \obeyspaces
+ \gdef\obeyedspace{ }
+
+ % Make each space character in the input produce a normal interword
+ % space in the output. Don't allow a line break at this space, as this
+ % is used only in environments like @example, where each line of input
+ % should produce a line of output anyway.
+ %
+ \gdef\sepspaces{\obeyspaces\let =\tie}
+
+ % If an index command is used in an @example environment, any spaces
+ % therein should become regular spaces in the raw index file, not the
+ % expansion of \tie (\leavevmode \penalty \@M \ ).
+ \gdef\unsepspaces{\let =\space}
+}
+
+
+\def\flushcr{\ifx\par\lisppar \def\next##1{}\else \let\next=\relax \fi \next}
+
+% Define the framework for environments in texinfo.tex. It's used like this:
+%
+% \envdef\foo{...}
+% \def\Efoo{...}
+%
+% It's the responsibility of \envdef to insert \begingroup before the
+% actual body; @end closes the group after calling \Efoo. \envdef also
+% defines \thisenv, so the current environment is known; @end checks
+% whether the environment name matches. The \checkenv macro can also be
+% used to check whether the current environment is the one expected.
+%
+% Non-false conditionals (@iftex, @ifset) don't fit into this, so they
+% are not treated as enviroments; they don't open a group. (The
+% implementation of @end takes care not to call \endgroup in this
+% special case.)
+
+
+% At runtime, environments start with this:
+\def\startenvironment#1{\begingroup\def\thisenv{#1}}
+% initialize
+\let\thisenv\empty
+
+% ... but they get defined via ``\envdef\foo{...}'':
+\long\def\envdef#1#2{\def#1{\startenvironment#1#2}}
+\def\envparseargdef#1#2{\parseargdef#1{\startenvironment#1#2}}
+
+% Check whether we're in the right environment:
+\def\checkenv#1{%
+ \def\temp{#1}%
+ \ifx\thisenv\temp
+ \else
+ \badenverr
+ \fi
+}
+
+% Evironment mismatch, #1 expected:
+\def\badenverr{%
+ \errhelp = \EMsimple
+ \errmessage{This command can appear only \inenvironment\temp,
+ not \inenvironment\thisenv}%
+}
+\def\inenvironment#1{%
+ \ifx#1\empty
+ out of any environment%
+ \else
+ in environment \expandafter\string#1%
+ \fi
+}
+
+% @end foo executes the definition of \Efoo.
+% But first, it executes a specialized version of \checkenv
+%
+\parseargdef\end{%
+ \if 1\csname iscond.#1\endcsname
+ \else
+ % The general wording of \badenverr may not be ideal, but... --kasal, 06nov03
+ \expandafter\checkenv\csname#1\endcsname
+ \csname E#1\endcsname
+ \endgroup
+ \fi
+}
+
+\newhelp\EMsimple{Press RETURN to continue.}
+
+
+%% Simple single-character @ commands
+
+% @@ prints an @
+% Kludge this until the fonts are right (grr).
+\def\@{{\tt\char64}}
+
+% This is turned off because it was never documented
+% and you can use @w{...} around a quote to suppress ligatures.
+%% Define @` and @' to be the same as ` and '
+%% but suppressing ligatures.
+%\def\`{{`}}
+%\def\'{{'}}
+
+% Used to generate quoted braces.
+\def\mylbrace {{\tt\char123}}
+\def\myrbrace {{\tt\char125}}
+\let\{=\mylbrace
+\let\}=\myrbrace
+\begingroup
+ % Definitions to produce \{ and \} commands for indices,
+ % and @{ and @} for the aux/toc files.
+ \catcode`\{ = \other \catcode`\} = \other
+ \catcode`\[ = 1 \catcode`\] = 2
+ \catcode`\! = 0 \catcode`\\ = \other
+ !gdef!lbracecmd[\{]%
+ !gdef!rbracecmd[\}]%
+ !gdef!lbraceatcmd[@{]%
+ !gdef!rbraceatcmd[@}]%
+!endgroup
+
+% @comma{} to avoid , parsing problems.
+\let\comma = ,
+
+% Accents: @, @dotaccent @ringaccent @ubaraccent @udotaccent
+% Others are defined by plain TeX: @` @' @" @^ @~ @= @u @v @H.
+\let\, = \c
+\let\dotaccent = \.
+\def\ringaccent#1{{\accent23 #1}}
+\let\tieaccent = \t
+\let\ubaraccent = \b
+\let\udotaccent = \d
+
+% Other special characters: @questiondown @exclamdown @ordf @ordm
+% Plain TeX defines: @AA @AE @O @OE @L (plus lowercase versions) @ss.
+\def\questiondown{?`}
+\def\exclamdown{!`}
+\def\ordf{\leavevmode\raise1ex\hbox{\selectfonts\lllsize \underbar{a}}}
+\def\ordm{\leavevmode\raise1ex\hbox{\selectfonts\lllsize \underbar{o}}}
+
+% Dotless i and dotless j, used for accents.
+\def\imacro{i}
+\def\jmacro{j}
+\def\dotless#1{%
+ \def\temp{#1}%
+ \ifx\temp\imacro \ptexi
+ \else\ifx\temp\jmacro \j
+ \else \errmessage{@dotless can be used only with i or j}%
+ \fi\fi
+}
+
+% The \TeX{} logo, as in plain, but resetting the spacing so that a
+% period following counts as ending a sentence. (Idea found in latex.)
+%
+\edef\TeX{\TeX \spacefactor=1000 }
+
+% @LaTeX{} logo. Not quite the same results as the definition in
+% latex.ltx, since we use a different font for the raised A; it's most
+% convenient for us to use an explicitly smaller font, rather than using
+% the \scriptstyle font (since we don't reset \scriptstyle and
+% \scriptscriptstyle).
+%
+\def\LaTeX{%
+ L\kern-.36em
+ {\setbox0=\hbox{T}%
+ \vbox to \ht0{\hbox{\selectfonts\lllsize A}\vss}}%
+ \kern-.15em
+ \TeX
+}
+
+% Be sure we're in horizontal mode when doing a tie, since we make space
+% equivalent to this in @example-like environments. Otherwise, a space
+% at the beginning of a line will start with \penalty -- and
+% since \penalty is valid in vertical mode, we'd end up putting the
+% penalty on the vertical list instead of in the new paragraph.
+{\catcode`@ = 11
+ % Avoid using \@M directly, because that causes trouble
+ % if the definition is written into an index file.
+ \global\let\tiepenalty = \@M
+ \gdef\tie{\leavevmode\penalty\tiepenalty\ }
+}
+
+% @: forces normal size whitespace following.
+\def\:{\spacefactor=1000 }
+
+% @* forces a line break.
+\def\*{\hfil\break\hbox{}\ignorespaces}
+
+% @/ allows a line break.
+\let\/=\allowbreak
+
+% @. is an end-of-sentence period.
+\def\.{.\spacefactor=\endofsentencespacefactor\space}
+
+% @! is an end-of-sentence bang.
+\def\!{!\spacefactor=\endofsentencespacefactor\space}
+
+% @? is an end-of-sentence query.
+\def\?{?\spacefactor=\endofsentencespacefactor\space}
+
+% @frenchspacing on|off says whether to put extra space after punctuation.
+%
+\def\onword{on}
+\def\offword{off}
+%
+\parseargdef\frenchspacing{%
+ \def\temp{#1}%
+ \ifx\temp\onword \plainfrenchspacing
+ \else\ifx\temp\offword \plainnonfrenchspacing
+ \else
+ \errhelp = \EMsimple
+ \errmessage{Unknown @frenchspacing option `\temp', must be on/off}%
+ \fi\fi
+}
+
+% @w prevents a word break. Without the \leavevmode, @w at the
+% beginning of a paragraph, when TeX is still in vertical mode, would
+% produce a whole line of output instead of starting the paragraph.
+\def\w#1{\leavevmode\hbox{#1}}
+
+% @group ... @end group forces ... to be all on one page, by enclosing
+% it in a TeX vbox. We use \vtop instead of \vbox to construct the box
+% to keep its height that of a normal line. According to the rules for
+% \topskip (p.114 of the TeXbook), the glue inserted is
+% max (\topskip - \ht (first item), 0). If that height is large,
+% therefore, no glue is inserted, and the space between the headline and
+% the text is small, which looks bad.
+%
+% Another complication is that the group might be very large. This can
+% cause the glue on the previous page to be unduly stretched, because it
+% does not have much material. In this case, it's better to add an
+% explicit \vfill so that the extra space is at the bottom. The
+% threshold for doing this is if the group is more than \vfilllimit
+% percent of a page (\vfilllimit can be changed inside of @tex).
+%
+\newbox\groupbox
+\def\vfilllimit{0.7}
+%
+\envdef\group{%
+ \ifnum\catcode`\^^M=\active \else
+ \errhelp = \groupinvalidhelp
+ \errmessage{@group invalid in context where filling is enabled}%
+ \fi
+ \startsavinginserts
+ %
+ \setbox\groupbox = \vtop\bgroup
+ % Do @comment since we are called inside an environment such as
+ % @example, where each end-of-line in the input causes an
+ % end-of-line in the output. We don't want the end-of-line after
+ % the `@group' to put extra space in the output. Since @group
+ % should appear on a line by itself (according to the Texinfo
+ % manual), we don't worry about eating any user text.
+ \comment
+}
+%
+% The \vtop produces a box with normal height and large depth; thus, TeX puts
+% \baselineskip glue before it, and (when the next line of text is done)
+% \lineskip glue after it. Thus, space below is not quite equal to space
+% above. But it's pretty close.
+\def\Egroup{%
+ % To get correct interline space between the last line of the group
+ % and the first line afterwards, we have to propagate \prevdepth.
+ \endgraf % Not \par, as it may have been set to \lisppar.
+ \global\dimen1 = \prevdepth
+ \egroup % End the \vtop.
+ % \dimen0 is the vertical size of the group's box.
+ \dimen0 = \ht\groupbox \advance\dimen0 by \dp\groupbox
+ % \dimen2 is how much space is left on the page (more or less).
+ \dimen2 = \pageheight \advance\dimen2 by -\pagetotal
+ % if the group doesn't fit on the current page, and it's a big big
+ % group, force a page break.
+ \ifdim \dimen0 > \dimen2
+ \ifdim \pagetotal < \vfilllimit\pageheight
+ \page
+ \fi
+ \fi
+ \box\groupbox
+ \prevdepth = \dimen1
+ \checkinserts
+}
+%
+% TeX puts in an \escapechar (i.e., `@') at the beginning of the help
+% message, so this ends up printing `@group can only ...'.
+%
+\newhelp\groupinvalidhelp{%
+group can only be used in environments such as @example,^^J%
+where each line of input produces a line of output.}
+
+% @need space-in-mils
+% forces a page break if there is not space-in-mils remaining.
+
+\newdimen\mil \mil=0.001in
+
+% Old definition--didn't work.
+%\parseargdef\need{\par %
+%% This method tries to make TeX break the page naturally
+%% if the depth of the box does not fit.
+%{\baselineskip=0pt%
+%\vtop to #1\mil{\vfil}\kern -#1\mil\nobreak
+%\prevdepth=-1000pt
+%}}
+
+\parseargdef\need{%
+ % Ensure vertical mode, so we don't make a big box in the middle of a
+ % paragraph.
+ \par
+ %
+ % If the @need value is less than one line space, it's useless.
+ \dimen0 = #1\mil
+ \dimen2 = \ht\strutbox
+ \advance\dimen2 by \dp\strutbox
+ \ifdim\dimen0 > \dimen2
+ %
+ % Do a \strut just to make the height of this box be normal, so the
+ % normal leading is inserted relative to the preceding line.
+ % And a page break here is fine.
+ \vtop to #1\mil{\strut\vfil}%
+ %
+ % TeX does not even consider page breaks if a penalty added to the
+ % main vertical list is 10000 or more. But in order to see if the
+ % empty box we just added fits on the page, we must make it consider
+ % page breaks. On the other hand, we don't want to actually break the
+ % page after the empty box. So we use a penalty of 9999.
+ %
+ % There is an extremely small chance that TeX will actually break the
+ % page at this \penalty, if there are no other feasible breakpoints in
+ % sight. (If the user is using lots of big @group commands, which
+ % almost-but-not-quite fill up a page, TeX will have a hard time doing
+ % good page breaking, for example.) However, I could not construct an
+ % example where a page broke at this \penalty; if it happens in a real
+ % document, then we can reconsider our strategy.
+ \penalty9999
+ %
+ % Back up by the size of the box, whether we did a page break or not.
+ \kern -#1\mil
+ %
+ % Do not allow a page break right after this kern.
+ \nobreak
+ \fi
+}
+
+% @br forces paragraph break (and is undocumented).
+
+\let\br = \par
+
+% @page forces the start of a new page.
+%
+\def\page{\par\vfill\supereject}
+
+% @exdent text....
+% outputs text on separate line in roman font, starting at standard page margin
+
+% This records the amount of indent in the innermost environment.
+% That's how much \exdent should take out.
+\newskip\exdentamount
+
+% This defn is used inside fill environments such as @defun.
+\parseargdef\exdent{\hfil\break\hbox{\kern -\exdentamount{\rm#1}}\hfil\break}
+
+% This defn is used inside nofill environments such as @example.
+\parseargdef\nofillexdent{{\advance \leftskip by -\exdentamount
+ \leftline{\hskip\leftskip{\rm#1}}}}
+
+% @inmargin{WHICH}{TEXT} puts TEXT in the WHICH margin next to the current
+% paragraph. For more general purposes, use the \margin insertion
+% class. WHICH is `l' or `r'.
+%
+\newskip\inmarginspacing \inmarginspacing=1cm
+\def\strutdepth{\dp\strutbox}
+%
+\def\doinmargin#1#2{\strut\vadjust{%
+ \nobreak
+ \kern-\strutdepth
+ \vtop to \strutdepth{%
+ \baselineskip=\strutdepth
+ \vss
+ % if you have multiple lines of stuff to put here, you'll need to
+ % make the vbox yourself of the appropriate size.
+ \ifx#1l%
+ \llap{\ignorespaces #2\hskip\inmarginspacing}%
+ \else
+ \rlap{\hskip\hsize \hskip\inmarginspacing \ignorespaces #2}%
+ \fi
+ \null
+ }%
+}}
+\def\inleftmargin{\doinmargin l}
+\def\inrightmargin{\doinmargin r}
+%
+% @inmargin{TEXT [, RIGHT-TEXT]}
+% (if RIGHT-TEXT is given, use TEXT for left page, RIGHT-TEXT for right;
+% else use TEXT for both).
+%
+\def\inmargin#1{\parseinmargin #1,,\finish}
+\def\parseinmargin#1,#2,#3\finish{% not perfect, but better than nothing.
+ \setbox0 = \hbox{\ignorespaces #2}%
+ \ifdim\wd0 > 0pt
+ \def\lefttext{#1}% have both texts
+ \def\righttext{#2}%
+ \else
+ \def\lefttext{#1}% have only one text
+ \def\righttext{#1}%
+ \fi
+ %
+ \ifodd\pageno
+ \def\temp{\inrightmargin\righttext}% odd page -> outside is right margin
+ \else
+ \def\temp{\inleftmargin\lefttext}%
+ \fi
+ \temp
+}
+
+% @include file insert text of that file as input.
+%
+\def\include{\parseargusing\filenamecatcodes\includezzz}
+\def\includezzz#1{%
+ \pushthisfilestack
+ \def\thisfile{#1}%
+ {%
+ \makevalueexpandable
+ \def\temp{\input #1 }%
+ \expandafter
+ }\temp
+ \popthisfilestack
+}
+\def\filenamecatcodes{%
+ \catcode`\\=\other
+ \catcode`~=\other
+ \catcode`^=\other
+ \catcode`_=\other
+ \catcode`|=\other
+ \catcode`<=\other
+ \catcode`>=\other
+ \catcode`+=\other
+ \catcode`-=\other
+}
+
+\def\pushthisfilestack{%
+ \expandafter\pushthisfilestackX\popthisfilestack\StackTerm
+}
+\def\pushthisfilestackX{%
+ \expandafter\pushthisfilestackY\thisfile\StackTerm
+}
+\def\pushthisfilestackY #1\StackTerm #2\StackTerm {%
+ \gdef\popthisfilestack{\gdef\thisfile{#1}\gdef\popthisfilestack{#2}}%
+}
+
+\def\popthisfilestack{\errthisfilestackempty}
+\def\errthisfilestackempty{\errmessage{Internal error:
+ the stack of filenames is empty.}}
+
+\def\thisfile{}
+
+% @center line
+% outputs that line, centered.
+%
+\parseargdef\center{%
+ \ifhmode
+ \let\next\centerH
+ \else
+ \let\next\centerV
+ \fi
+ \next{\hfil \ignorespaces#1\unskip \hfil}%
+}
+\def\centerH#1{%
+ {%
+ \hfil\break
+ \advance\hsize by -\leftskip
+ \advance\hsize by -\rightskip
+ \line{#1}%
+ \break
+ }%
+}
+\def\centerV#1{\line{\kern\leftskip #1\kern\rightskip}}
+
+% @sp n outputs n lines of vertical space
+
+\parseargdef\sp{\vskip #1\baselineskip}
+
+% @comment ...line which is ignored...
+% @c is the same as @comment
+% @ignore ... @end ignore is another way to write a comment
+
+\def\comment{\begingroup \catcode`\^^M=\other%
+\catcode`\@=\other \catcode`\{=\other \catcode`\}=\other%
+\commentxxx}
+{\catcode`\^^M=\other \gdef\commentxxx#1^^M{\endgroup}}
+
+\let\c=\comment
+
+% @paragraphindent NCHARS
+% We'll use ems for NCHARS, close enough.
+% NCHARS can also be the word `asis' or `none'.
+% We cannot feasibly implement @paragraphindent asis, though.
+%
+\def\asisword{asis} % no translation, these are keywords
+\def\noneword{none}
+%
+\parseargdef\paragraphindent{%
+ \def\temp{#1}%
+ \ifx\temp\asisword
+ \else
+ \ifx\temp\noneword
+ \defaultparindent = 0pt
+ \else
+ \defaultparindent = #1em
+ \fi
+ \fi
+ \parindent = \defaultparindent
+}
+
+% @exampleindent NCHARS
+% We'll use ems for NCHARS like @paragraphindent.
+% It seems @exampleindent asis isn't necessary, but
+% I preserve it to make it similar to @paragraphindent.
+\parseargdef\exampleindent{%
+ \def\temp{#1}%
+ \ifx\temp\asisword
+ \else
+ \ifx\temp\noneword
+ \lispnarrowing = 0pt
+ \else
+ \lispnarrowing = #1em
+ \fi
+ \fi
+}
+
+% @firstparagraphindent WORD
+% If WORD is `none', then suppress indentation of the first paragraph
+% after a section heading. If WORD is `insert', then do indent at such
+% paragraphs.
+%
+% The paragraph indentation is suppressed or not by calling
+% \suppressfirstparagraphindent, which the sectioning commands do.
+% We switch the definition of this back and forth according to WORD.
+% By default, we suppress indentation.
+%
+\def\suppressfirstparagraphindent{\dosuppressfirstparagraphindent}
+\def\insertword{insert}
+%
+\parseargdef\firstparagraphindent{%
+ \def\temp{#1}%
+ \ifx\temp\noneword
+ \let\suppressfirstparagraphindent = \dosuppressfirstparagraphindent
+ \else\ifx\temp\insertword
+ \let\suppressfirstparagraphindent = \relax
+ \else
+ \errhelp = \EMsimple
+ \errmessage{Unknown @firstparagraphindent option `\temp'}%
+ \fi\fi
+}
+
+% Here is how we actually suppress indentation. Redefine \everypar to
+% \kern backwards by \parindent, and then reset itself to empty.
+%
+% We also make \indent itself not actually do anything until the next
+% paragraph.
+%
+\gdef\dosuppressfirstparagraphindent{%
+ \gdef\indent{%
+ \restorefirstparagraphindent
+ \indent
+ }%
+ \gdef\noindent{%
+ \restorefirstparagraphindent
+ \noindent
+ }%
+ \global\everypar = {%
+ \kern -\parindent
+ \restorefirstparagraphindent
+ }%
+}
+
+\gdef\restorefirstparagraphindent{%
+ \global \let \indent = \ptexindent
+ \global \let \noindent = \ptexnoindent
+ \global \everypar = {}%
+}
+
+
+% @asis just yields its argument. Used with @table, for example.
+%
+\def\asis#1{#1}
+
+% @math outputs its argument in math mode.
+%
+% One complication: _ usually means subscripts, but it could also mean
+% an actual _ character, as in @math{@var{some_variable} + 1}. So make
+% _ active, and distinguish by seeing if the current family is \slfam,
+% which is what @var uses.
+{
+ \catcode`\_ = \active
+ \gdef\mathunderscore{%
+ \catcode`\_=\active
+ \def_{\ifnum\fam=\slfam \_\else\sb\fi}%
+ }
+}
+% Another complication: we want \\ (and @\) to output a \ character.
+% FYI, plain.tex uses \\ as a temporary control sequence (why?), but
+% this is not advertised and we don't care. Texinfo does not
+% otherwise define @\.
+%
+% The \mathchar is class=0=ordinary, family=7=ttfam, position=5C=\.
+\def\mathbackslash{\ifnum\fam=\ttfam \mathchar"075C \else\backslash \fi}
+%
+\def\math{%
+ \tex
+ \mathunderscore
+ \let\\ = \mathbackslash
+ \mathactive
+ $\finishmath
+}
+\def\finishmath#1{#1$\endgroup} % Close the group opened by \tex.
+
+% Some active characters (such as <) are spaced differently in math.
+% We have to reset their definitions in case the @math was an argument
+% to a command which sets the catcodes (such as @item or @section).
+%
+{
+ \catcode`^ = \active
+ \catcode`< = \active
+ \catcode`> = \active
+ \catcode`+ = \active
+ \gdef\mathactive{%
+ \let^ = \ptexhat
+ \let< = \ptexless
+ \let> = \ptexgtr
+ \let+ = \ptexplus
+ }
+}
+
+% @bullet and @minus need the same treatment as @math, just above.
+\def\bullet{$\ptexbullet$}
+\def\minus{$-$}
+
+% @dots{} outputs an ellipsis using the current font.
+% We do .5em per period so that it has the same spacing in the cm
+% typewriter fonts as three actual period characters; on the other hand,
+% in other typewriter fonts three periods are wider than 1.5em. So do
+% whichever is larger.
+%
+\def\dots{%
+ \leavevmode
+ \setbox0=\hbox{...}% get width of three periods
+ \ifdim\wd0 > 1.5em
+ \dimen0 = \wd0
+ \else
+ \dimen0 = 1.5em
+ \fi
+ \hbox to \dimen0{%
+ \hskip 0pt plus.25fil
+ .\hskip 0pt plus1fil
+ .\hskip 0pt plus1fil
+ .\hskip 0pt plus.5fil
+ }%
+}
+
+% @enddots{} is an end-of-sentence ellipsis.
+%
+\def\enddots{%
+ \dots
+ \spacefactor=\endofsentencespacefactor
+}
+
+% @comma{} is so commas can be inserted into text without messing up
+% Texinfo's parsing.
+%
+\let\comma = ,
+
+% @refill is a no-op.
+\let\refill=\relax
+
+% If working on a large document in chapters, it is convenient to
+% be able to disable indexing, cross-referencing, and contents, for test runs.
+% This is done with @novalidate (before @setfilename).
+%
+\newif\iflinks \linkstrue % by default we want the aux files.
+\let\novalidate = \linksfalse
+
+% @setfilename is done at the beginning of every texinfo file.
+% So open here the files we need to have open while reading the input.
+% This makes it possible to make a .fmt file for texinfo.
+\def\setfilename{%
+ \fixbackslash % Turn off hack to swallow `\input texinfo'.
+ \iflinks
+ \tryauxfile
+ % Open the new aux file. TeX will close it automatically at exit.
+ \immediate\openout\auxfile=\jobname.aux
+ \fi % \openindices needs to do some work in any case.
+ \openindices
+ \let\setfilename=\comment % Ignore extra @setfilename cmds.
+ %
+ % If texinfo.cnf is present on the system, read it.
+ % Useful for site-wide @afourpaper, etc.
+ \openin 1 texinfo.cnf
+ \ifeof 1 \else \input texinfo.cnf \fi
+ \closein 1
+ %
+ \comment % Ignore the actual filename.
+}
+
+% Called from \setfilename.
+%
+\def\openindices{%
+ \newindex{cp}%
+ \newcodeindex{fn}%
+ \newcodeindex{vr}%
+ \newcodeindex{tp}%
+ \newcodeindex{ky}%
+ \newcodeindex{pg}%
+}
+
+% @bye.
+\outer\def\bye{\pagealignmacro\tracingstats=1\ptexend}
+
+
+\message{pdf,}
+% adobe `portable' document format
+\newcount\tempnum
+\newcount\lnkcount
+\newtoks\filename
+\newcount\filenamelength
+\newcount\pgn
+\newtoks\toksA
+\newtoks\toksB
+\newtoks\toksC
+\newtoks\toksD
+\newbox\boxA
+\newcount\countA
+\newif\ifpdf
+\newif\ifpdfmakepagedest
+
+% when pdftex is run in dvi mode, \pdfoutput is defined (so \pdfoutput=1
+% can be set). So we test for \relax and 0 as well as \undefined,
+% borrowed from ifpdf.sty.
+\ifx\pdfoutput\undefined
+\else
+ \ifx\pdfoutput\relax
+ \else
+ \ifcase\pdfoutput
+ \else
+ \pdftrue
+ \fi
+ \fi
+\fi
+
+% PDF uses PostScript string constants for the names of xref targets,
+% for display in the outlines, and in other places. Thus, we have to
+% double any backslashes. Otherwise, a name like "\node" will be
+% interpreted as a newline (\n), followed by o, d, e. Not good.
+% http://www.ntg.nl/pipermail/ntg-pdftex/2004-July/000654.html
+% (and related messages, the final outcome is that it is up to the TeX
+% user to double the backslashes and otherwise make the string valid, so
+% that's what we do).
+
+% double active backslashes.
+%
+{\catcode`\@=0 \catcode`\\=\active
+ @gdef@activebackslashdouble{%
+ @catcode`@\=@active
+ @let\=@doublebackslash}
+}
+
+% To handle parens, we must adopt a different approach, since parens are
+% not active characters. hyperref.dtx (which has the same problem as
+% us) handles it with this amazing macro to replace tokens, with minor
+% changes for Texinfo. It is included here under the GPL by permission
+% from the author, Heiko Oberdiek.
+%
+% #1 is the tokens to replace.
+% #2 is the replacement.
+% #3 is the control sequence with the string.
+%
+\def\HyPsdSubst#1#2#3{%
+ \def\HyPsdReplace##1#1##2\END{%
+ ##1%
+ \ifx\\##2\\%
+ \else
+ #2%
+ \HyReturnAfterFi{%
+ \HyPsdReplace##2\END
+ }%
+ \fi
+ }%
+ \xdef#3{\expandafter\HyPsdReplace#3#1\END}%
+}
+\long\def\HyReturnAfterFi#1\fi{\fi#1}
+
+% #1 is a control sequence in which to do the replacements.
+\def\backslashparens#1{%
+ \xdef#1{#1}% redefine it as its expansion; the definition is simply
+ % \lastnode when called from \setref -> \pdfmkdest.
+ \HyPsdSubst{(}{\realbackslash(}{#1}%
+ \HyPsdSubst{)}{\realbackslash)}{#1}%
+}
+
+\newhelp\nopdfimagehelp{Texinfo supports .png, .jpg, .jpeg, and .pdf images
+with PDF output, and none of those formats could be found. (.eps cannot
+be supported due to the design of the PDF format; use regular TeX (DVI
+output) for that.)}
+
+\ifpdf
+ %
+ % Color manipulation macros based on pdfcolor.tex.
+ \def\cmykDarkRed{0.28 1 1 0.35}
+ \def\cmykBlack{0 0 0 1}
+ %
+ \def\pdfsetcolor#1{\pdfliteral{#1 k}}
+ % Set color, and create a mark which defines \thiscolor accordingly,
+ % so that \makeheadline knows which color to restore.
+ \def\setcolor#1{%
+ \xdef\lastcolordefs{\gdef\noexpand\thiscolor{#1}}%
+ \domark
+ \pdfsetcolor{#1}%
+ }
+ %
+ \def\maincolor{\cmykBlack}
+ \pdfsetcolor{\maincolor}
+ \edef\thiscolor{\maincolor}
+ \def\lastcolordefs{}
+ %
+ \def\makefootline{%
+ \baselineskip24pt
+ \line{\pdfsetcolor{\maincolor}\the\footline}%
+ }
+ %
+ \def\makeheadline{%
+ \vbox to 0pt{%
+ \vskip-22.5pt
+ \line{%
+ \vbox to8.5pt{}%
+ % Extract \thiscolor definition from the marks.
+ \getcolormarks
+ % Typeset the headline with \maincolor, then restore the color.
+ \pdfsetcolor{\maincolor}\the\headline\pdfsetcolor{\thiscolor}%
+ }%
+ \vss
+ }%
+ \nointerlineskip
+ }
+ %
+ %
+ \pdfcatalog{/PageMode /UseOutlines}
+ %
+ % #1 is image name, #2 width (might be empty/whitespace), #3 height (ditto).
+ \def\dopdfimage#1#2#3{%
+ \def\imagewidth{#2}\setbox0 = \hbox{\ignorespaces #2}%
+ \def\imageheight{#3}\setbox2 = \hbox{\ignorespaces #3}%
+ %
+ % pdftex (and the PDF format) support .png, .jpg, .pdf (among
+ % others). Let's try in that order.
+ \let\pdfimgext=\empty
+ \begingroup
+ \openin 1 #1.png \ifeof 1
+ \openin 1 #1.jpg \ifeof 1
+ \openin 1 #1.jpeg \ifeof 1
+ \openin 1 #1.JPG \ifeof 1
+ \openin 1 #1.pdf \ifeof 1
+ \errhelp = \nopdfimagehelp
+ \errmessage{Could not find image file #1 for pdf}%
+ \else \gdef\pdfimgext{pdf}%
+ \fi
+ \else \gdef\pdfimgext{JPG}%
+ \fi
+ \else \gdef\pdfimgext{jpeg}%
+ \fi
+ \else \gdef\pdfimgext{jpg}%
+ \fi
+ \else \gdef\pdfimgext{png}%
+ \fi
+ \closein 1
+ \endgroup
+ %
+ % without \immediate, pdftex seg faults when the same image is
+ % included twice. (Version 3.14159-pre-1.0-unofficial-20010704.)
+ \ifnum\pdftexversion < 14
+ \immediate\pdfimage
+ \else
+ \immediate\pdfximage
+ \fi
+ \ifdim \wd0 >0pt width \imagewidth \fi
+ \ifdim \wd2 >0pt height \imageheight \fi
+ \ifnum\pdftexversion<13
+ #1.\pdfimgext
+ \else
+ {#1.\pdfimgext}%
+ \fi
+ \ifnum\pdftexversion < 14 \else
+ \pdfrefximage \pdflastximage
+ \fi}
+ %
+ \def\pdfmkdest#1{{%
+ % We have to set dummies so commands such as @code, and characters
+ % such as \, aren't expanded when present in a section title.
+ \indexnofonts
+ \turnoffactive
+ \activebackslashdouble
+ \makevalueexpandable
+ \def\pdfdestname{#1}%
+ \backslashparens\pdfdestname
+ \safewhatsit{\pdfdest name{\pdfdestname} xyz}%
+ }}
+ %
+ % used to mark target names; must be expandable.
+ \def\pdfmkpgn#1{#1}
+ %
+ % by default, use a color that is dark enough to print on paper as
+ % nearly black, but still distinguishable for online viewing.
+ \def\urlcolor{\cmykDarkRed}
+ \def\linkcolor{\cmykDarkRed}
+ \def\endlink{\setcolor{\maincolor}\pdfendlink}
+ %
+ % Adding outlines to PDF; macros for calculating structure of outlines
+ % come from Petr Olsak
+ \def\expnumber#1{\expandafter\ifx\csname#1\endcsname\relax 0%
+ \else \csname#1\endcsname \fi}
+ \def\advancenumber#1{\tempnum=\expnumber{#1}\relax
+ \advance\tempnum by 1
+ \expandafter\xdef\csname#1\endcsname{\the\tempnum}}
+ %
+ % #1 is the section text, which is what will be displayed in the
+ % outline by the pdf viewer. #2 is the pdf expression for the number
+ % of subentries (or empty, for subsubsections). #3 is the node text,
+ % which might be empty if this toc entry had no corresponding node.
+ % #4 is the page number
+ %
+ \def\dopdfoutline#1#2#3#4{%
+ % Generate a link to the node text if that exists; else, use the
+ % page number. We could generate a destination for the section
+ % text in the case where a section has no node, but it doesn't
+ % seem worth the trouble, since most documents are normally structured.
+ \def\pdfoutlinedest{#3}%
+ \ifx\pdfoutlinedest\empty
+ \def\pdfoutlinedest{#4}%
+ \else
+ % Doubled backslashes in the name.
+ {\activebackslashdouble \xdef\pdfoutlinedest{#3}%
+ \backslashparens\pdfoutlinedest}%
+ \fi
+ %
+ % Also double the backslashes in the display string.
+ {\activebackslashdouble \xdef\pdfoutlinetext{#1}%
+ \backslashparens\pdfoutlinetext}%
+ %
+ \pdfoutline goto name{\pdfmkpgn{\pdfoutlinedest}}#2{\pdfoutlinetext}%
+ }
+ %
+ \def\pdfmakeoutlines{%
+ \begingroup
+ % Thanh's hack / proper braces in bookmarks
+ \edef\mylbrace{\iftrue \string{\else}\fi}\let\{=\mylbrace
+ \edef\myrbrace{\iffalse{\else\string}\fi}\let\}=\myrbrace
+ %
+ % Read toc silently, to get counts of subentries for \pdfoutline.
+ \def\numchapentry##1##2##3##4{%
+ \def\thischapnum{##2}%
+ \def\thissecnum{0}%
+ \def\thissubsecnum{0}%
+ }%
+ \def\numsecentry##1##2##3##4{%
+ \advancenumber{chap\thischapnum}%
+ \def\thissecnum{##2}%
+ \def\thissubsecnum{0}%
+ }%
+ \def\numsubsecentry##1##2##3##4{%
+ \advancenumber{sec\thissecnum}%
+ \def\thissubsecnum{##2}%
+ }%
+ \def\numsubsubsecentry##1##2##3##4{%
+ \advancenumber{subsec\thissubsecnum}%
+ }%
+ \def\thischapnum{0}%
+ \def\thissecnum{0}%
+ \def\thissubsecnum{0}%
+ %
+ % use \def rather than \let here because we redefine \chapentry et
+ % al. a second time, below.
+ \def\appentry{\numchapentry}%
+ \def\appsecentry{\numsecentry}%
+ \def\appsubsecentry{\numsubsecentry}%
+ \def\appsubsubsecentry{\numsubsubsecentry}%
+ \def\unnchapentry{\numchapentry}%
+ \def\unnsecentry{\numsecentry}%
+ \def\unnsubsecentry{\numsubsecentry}%
+ \def\unnsubsubsecentry{\numsubsubsecentry}%
+ \readdatafile{toc}%
+ %
+ % Read toc second time, this time actually producing the outlines.
+ % The `-' means take the \expnumber as the absolute number of
+ % subentries, which we calculated on our first read of the .toc above.
+ %
+ % We use the node names as the destinations.
+ \def\numchapentry##1##2##3##4{%
+ \dopdfoutline{##1}{count-\expnumber{chap##2}}{##3}{##4}}%
+ \def\numsecentry##1##2##3##4{%
+ \dopdfoutline{##1}{count-\expnumber{sec##2}}{##3}{##4}}%
+ \def\numsubsecentry##1##2##3##4{%
+ \dopdfoutline{##1}{count-\expnumber{subsec##2}}{##3}{##4}}%
+ \def\numsubsubsecentry##1##2##3##4{% count is always zero
+ \dopdfoutline{##1}{}{##3}{##4}}%
+ %
+ % PDF outlines are displayed using system fonts, instead of
+ % document fonts. Therefore we cannot use special characters,
+ % since the encoding is unknown. For example, the eogonek from
+ % Latin 2 (0xea) gets translated to a | character. Info from
+ % Staszek Wawrykiewicz, 19 Jan 2004 04:09:24 +0100.
+ %
+ % xx to do this right, we have to translate 8-bit characters to
+ % their "best" equivalent, based on the @documentencoding. Right
+ % now, I guess we'll just let the pdf reader have its way.
+ \indexnofonts
+ \setupdatafile
+ \catcode`\\=\active \otherbackslash
+ \input \tocreadfilename
+ \endgroup
+ }
+ %
+ \def\skipspaces#1{\def\PP{#1}\def\D{|}%
+ \ifx\PP\D\let\nextsp\relax
+ \else\let\nextsp\skipspaces
+ \ifx\p\space\else\addtokens{\filename}{\PP}%
+ \advance\filenamelength by 1
+ \fi
+ \fi
+ \nextsp}
+ \def\getfilename#1{\filenamelength=0\expandafter\skipspaces#1|\relax}
+ \ifnum\pdftexversion < 14
+ \let \startlink \pdfannotlink
+ \else
+ \let \startlink \pdfstartlink
+ \fi
+ % make a live url in pdf output.
+ \def\pdfurl#1{%
+ \begingroup
+ % it seems we really need yet another set of dummies; have not
+ % tried to figure out what each command should do in the context
+ % of @url. for now, just make @/ a no-op, that's the only one
+ % people have actually reported a problem with.
+ %
+ \normalturnoffactive
+ \def\@{@}%
+ \let\/=\empty
+ \makevalueexpandable
+ \leavevmode\setcolor{\urlcolor}%
+ \startlink attr{/Border [0 0 0]}%
+ user{/Subtype /Link /A << /S /URI /URI (#1) >>}%
+ \endgroup}
+ \def\pdfgettoks#1.{\setbox\boxA=\hbox{\toksA={#1.}\toksB={}\maketoks}}
+ \def\addtokens#1#2{\edef\addtoks{\noexpand#1={\the#1#2}}\addtoks}
+ \def\adn#1{\addtokens{\toksC}{#1}\global\countA=1\let\next=\maketoks}
+ \def\poptoks#1#2|ENDTOKS|{\let\first=#1\toksD={#1}\toksA={#2}}
+ \def\maketoks{%
+ \expandafter\poptoks\the\toksA|ENDTOKS|\relax
+ \ifx\first0\adn0
+ \else\ifx\first1\adn1 \else\ifx\first2\adn2 \else\ifx\first3\adn3
+ \else\ifx\first4\adn4 \else\ifx\first5\adn5 \else\ifx\first6\adn6
+ \else\ifx\first7\adn7 \else\ifx\first8\adn8 \else\ifx\first9\adn9
+ \else
+ \ifnum0=\countA\else\makelink\fi
+ \ifx\first.\let\next=\done\else
+ \let\next=\maketoks
+ \addtokens{\toksB}{\the\toksD}
+ \ifx\first,\addtokens{\toksB}{\space}\fi
+ \fi
+ \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi
+ \next}
+ \def\makelink{\addtokens{\toksB}%
+ {\noexpand\pdflink{\the\toksC}}\toksC={}\global\countA=0}
+ \def\pdflink#1{%
+ \startlink attr{/Border [0 0 0]} goto name{\pdfmkpgn{#1}}
+ \setcolor{\linkcolor}#1\endlink}
+ \def\done{\edef\st{\global\noexpand\toksA={\the\toksB}}\st}
+\else
+ \let\pdfmkdest = \gobble
+ \let\pdfurl = \gobble
+ \let\endlink = \relax
+ \let\setcolor = \gobble
+ \let\pdfsetcolor = \gobble
+ \let\pdfmakeoutlines = \relax
+\fi % \ifx\pdfoutput
+
+
+\message{fonts,}
+
+% Change the current font style to #1, remembering it in \curfontstyle.
+% For now, we do not accumulate font styles: @b{@i{foo}} prints foo in
+% italics, not bold italics.
+%
+\def\setfontstyle#1{%
+ \def\curfontstyle{#1}% not as a control sequence, because we are \edef'd.
+ \csname ten#1\endcsname % change the current font
+}
+
+% Select #1 fonts with the current style.
+%
+\def\selectfonts#1{\csname #1fonts\endcsname \csname\curfontstyle\endcsname}
+
+\def\rm{\fam=0 \setfontstyle{rm}}
+\def\it{\fam=\itfam \setfontstyle{it}}
+\def\sl{\fam=\slfam \setfontstyle{sl}}
+\def\bf{\fam=\bffam \setfontstyle{bf}}\def\bfstylename{bf}
+\def\tt{\fam=\ttfam \setfontstyle{tt}}
+
+% Texinfo sort of supports the sans serif font style, which plain TeX does not.
+% So we set up a \sf.
+\newfam\sffam
+\def\sf{\fam=\sffam \setfontstyle{sf}}
+\let\li = \sf % Sometimes we call it \li, not \sf.
+
+% We don't need math for this font style.
+\def\ttsl{\setfontstyle{ttsl}}
+
+
+% Default leading.
+\newdimen\textleading \textleading = 13.2pt
+
+% Set the baselineskip to #1, and the lineskip and strut size
+% correspondingly. There is no deep meaning behind these magic numbers
+% used as factors; they just match (closely enough) what Knuth defined.
+%
+\def\lineskipfactor{.08333}
+\def\strutheightpercent{.70833}
+\def\strutdepthpercent {.29167}
+%
+% can get a sort of poor man's double spacing by redefining this.
+\def\baselinefactor{1}
+%
+\def\setleading#1{%
+ \dimen0 = #1\relax
+ \normalbaselineskip = \baselinefactor\dimen0
+ \normallineskip = \lineskipfactor\normalbaselineskip
+ \normalbaselines
+ \setbox\strutbox =\hbox{%
+ \vrule width0pt height\strutheightpercent\baselineskip
+ depth \strutdepthpercent \baselineskip
+ }%
+}
+
+% PDF CMaps. See also LaTeX's t1.cmap.
+%
+% do nothing with this by default.
+\expandafter\let\csname cmapOT1\endcsname\gobble
+\expandafter\let\csname cmapOT1IT\endcsname\gobble
+\expandafter\let\csname cmapOT1TT\endcsname\gobble
+
+% if we are producing pdf, and we have \pdffontattr, then define cmaps.
+% (\pdffontattr was introduced many years ago, but people still run
+% older pdftex's; it's easy to conditionalize, so we do.)
+\ifpdf \ifx\pdffontattr\undefined \else
+ \begingroup
+ \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char.
+ \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap
+%%DocumentNeededResources: ProcSet (CIDInit)
+%%IncludeResource: ProcSet (CIDInit)
+%%BeginResource: CMap (TeX-OT1-0)
+%%Title: (TeX-OT1-0 TeX OT1 0)
+%%Version: 1.000
+%%EndComments
+/CIDInit /ProcSet findresource begin
+12 dict begin
+begincmap
+/CIDSystemInfo
+<< /Registry (TeX)
+/Ordering (OT1)
+/Supplement 0
+>> def
+/CMapName /TeX-OT1-0 def
+/CMapType 2 def
+1 begincodespacerange
+<00> <7F>
+endcodespacerange
+8 beginbfrange
+<00> <01> <0393>
+<09> <0A> <03A8>
+<23> <26> <0023>
+<28> <3B> <0028>
+<3F> <5B> <003F>
+<5D> <5E> <005D>
+<61> <7A> <0061>
+<7B> <7C> <2013>
+endbfrange
+40 beginbfchar
+<02> <0398>
+<03> <039B>
+<04> <039E>
+<05> <03A0>
+<06> <03A3>
+<07> <03D2>
+<08> <03A6>
+<0B> <00660066>
+<0C> <00660069>
+<0D> <0066006C>
+<0E> <006600660069>
+<0F> <00660066006C>
+<10> <0131>
+<11> <0237>
+<12> <0060>
+<13> <00B4>
+<14> <02C7>
+<15> <02D8>
+<16> <00AF>
+<17> <02DA>
+<18> <00B8>
+<19> <00DF>
+<1A> <00E6>
+<1B> <0153>
+<1C> <00F8>
+<1D> <00C6>
+<1E> <0152>
+<1F> <00D8>
+<21> <0021>
+<22> <201D>
+<27> <2019>
+<3C> <00A1>
+<3D> <003D>
+<3E> <00BF>
+<5C> <201C>
+<5F> <02D9>
+<60> <2018>
+<7D> <02DD>
+<7E> <007E>
+<7F> <00A8>
+endbfchar
+endcmap
+CMapName currentdict /CMap defineresource pop
+end
+end
+%%EndResource
+%%EOF
+ }\endgroup
+ \expandafter\edef\csname cmapOT1\endcsname#1{%
+ \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}%
+ }%
+%
+% \cmapOT1IT
+ \begingroup
+ \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char.
+ \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap
+%%DocumentNeededResources: ProcSet (CIDInit)
+%%IncludeResource: ProcSet (CIDInit)
+%%BeginResource: CMap (TeX-OT1IT-0)
+%%Title: (TeX-OT1IT-0 TeX OT1IT 0)
+%%Version: 1.000
+%%EndComments
+/CIDInit /ProcSet findresource begin
+12 dict begin
+begincmap
+/CIDSystemInfo
+<< /Registry (TeX)
+/Ordering (OT1IT)
+/Supplement 0
+>> def
+/CMapName /TeX-OT1IT-0 def
+/CMapType 2 def
+1 begincodespacerange
+<00> <7F>
+endcodespacerange
+8 beginbfrange
+<00> <01> <0393>
+<09> <0A> <03A8>
+<25> <26> <0025>
+<28> <3B> <0028>
+<3F> <5B> <003F>
+<5D> <5E> <005D>
+<61> <7A> <0061>
+<7B> <7C> <2013>
+endbfrange
+42 beginbfchar
+<02> <0398>
+<03> <039B>
+<04> <039E>
+<05> <03A0>
+<06> <03A3>
+<07> <03D2>
+<08> <03A6>
+<0B> <00660066>
+<0C> <00660069>
+<0D> <0066006C>
+<0E> <006600660069>
+<0F> <00660066006C>
+<10> <0131>
+<11> <0237>
+<12> <0060>
+<13> <00B4>
+<14> <02C7>
+<15> <02D8>
+<16> <00AF>
+<17> <02DA>
+<18> <00B8>
+<19> <00DF>
+<1A> <00E6>
+<1B> <0153>
+<1C> <00F8>
+<1D> <00C6>
+<1E> <0152>
+<1F> <00D8>
+<21> <0021>
+<22> <201D>
+<23> <0023>
+<24> <00A3>
+<27> <2019>
+<3C> <00A1>
+<3D> <003D>
+<3E> <00BF>
+<5C> <201C>
+<5F> <02D9>
+<60> <2018>
+<7D> <02DD>
+<7E> <007E>
+<7F> <00A8>
+endbfchar
+endcmap
+CMapName currentdict /CMap defineresource pop
+end
+end
+%%EndResource
+%%EOF
+ }\endgroup
+ \expandafter\edef\csname cmapOT1IT\endcsname#1{%
+ \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}%
+ }%
+%
+% \cmapOT1TT
+ \begingroup
+ \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char.
+ \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap
+%%DocumentNeededResources: ProcSet (CIDInit)
+%%IncludeResource: ProcSet (CIDInit)
+%%BeginResource: CMap (TeX-OT1TT-0)
+%%Title: (TeX-OT1TT-0 TeX OT1TT 0)
+%%Version: 1.000
+%%EndComments
+/CIDInit /ProcSet findresource begin
+12 dict begin
+begincmap
+/CIDSystemInfo
+<< /Registry (TeX)
+/Ordering (OT1TT)
+/Supplement 0
+>> def
+/CMapName /TeX-OT1TT-0 def
+/CMapType 2 def
+1 begincodespacerange
+<00> <7F>
+endcodespacerange
+5 beginbfrange
+<00> <01> <0393>
+<09> <0A> <03A8>
+<21> <26> <0021>
+<28> <5F> <0028>
+<61> <7E> <0061>
+endbfrange
+32 beginbfchar
+<02> <0398>
+<03> <039B>
+<04> <039E>
+<05> <03A0>
+<06> <03A3>
+<07> <03D2>
+<08> <03A6>
+<0B> <2191>
+<0C> <2193>
+<0D> <0027>
+<0E> <00A1>
+<0F> <00BF>
+<10> <0131>
+<11> <0237>
+<12> <0060>
+<13> <00B4>
+<14> <02C7>
+<15> <02D8>
+<16> <00AF>
+<17> <02DA>
+<18> <00B8>
+<19> <00DF>
+<1A> <00E6>
+<1B> <0153>
+<1C> <00F8>
+<1D> <00C6>
+<1E> <0152>
+<1F> <00D8>
+<20> <2423>
+<27> <2019>
+<60> <2018>
+<7F> <00A8>
+endbfchar
+endcmap
+CMapName currentdict /CMap defineresource pop
+end
+end
+%%EndResource
+%%EOF
+ }\endgroup
+ \expandafter\edef\csname cmapOT1TT\endcsname#1{%
+ \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}%
+ }%
+\fi\fi
+
+
+% Set the font macro #1 to the font named #2, adding on the
+% specified font prefix (normally `cm').
+% #3 is the font's design size, #4 is a scale factor, #5 is the CMap
+% encoding (currently only OT1, OT1IT and OT1TT are allowed, pass
+% empty to omit).
+\def\setfont#1#2#3#4#5{%
+ \font#1=\fontprefix#2#3 scaled #4
+ \csname cmap#5\endcsname#1%
+}
+% This is what gets called when #5 of \setfont is empty.
+\let\cmap\gobble
+% emacs-page end of cmaps
+
+% Use cm as the default font prefix.
+% To specify the font prefix, you must define \fontprefix
+% before you read in texinfo.tex.
+\ifx\fontprefix\undefined
+\def\fontprefix{cm}
+\fi
+% Support font families that don't use the same naming scheme as CM.
+\def\rmshape{r}
+\def\rmbshape{bx} %where the normal face is bold
+\def\bfshape{b}
+\def\bxshape{bx}
+\def\ttshape{tt}
+\def\ttbshape{tt}
+\def\ttslshape{sltt}
+\def\itshape{ti}
+\def\itbshape{bxti}
+\def\slshape{sl}
+\def\slbshape{bxsl}
+\def\sfshape{ss}
+\def\sfbshape{ss}
+\def\scshape{csc}
+\def\scbshape{csc}
+
+% Definitions for a main text size of 11pt. This is the default in
+% Texinfo.
+%
+\def\definetextfontsizexi{%
+% Text fonts (11.2pt, magstep1).
+\def\textnominalsize{11pt}
+\edef\mainmagstep{\magstephalf}
+\setfont\textrm\rmshape{10}{\mainmagstep}{OT1}
+\setfont\texttt\ttshape{10}{\mainmagstep}{OT1TT}
+\setfont\textbf\bfshape{10}{\mainmagstep}{OT1}
+\setfont\textit\itshape{10}{\mainmagstep}{OT1IT}
+\setfont\textsl\slshape{10}{\mainmagstep}{OT1}
+\setfont\textsf\sfshape{10}{\mainmagstep}{OT1}
+\setfont\textsc\scshape{10}{\mainmagstep}{OT1}
+\setfont\textttsl\ttslshape{10}{\mainmagstep}{OT1TT}
+\font\texti=cmmi10 scaled \mainmagstep
+\font\textsy=cmsy10 scaled \mainmagstep
+\def\textecsize{1095}
+
+% A few fonts for @defun names and args.
+\setfont\defbf\bfshape{10}{\magstep1}{OT1}
+\setfont\deftt\ttshape{10}{\magstep1}{OT1TT}
+\setfont\defttsl\ttslshape{10}{\magstep1}{OT1TT}
+\def\df{\let\tentt=\deftt \let\tenbf = \defbf \let\tenttsl=\defttsl \bf}
+
+% Fonts for indices, footnotes, small examples (9pt).
+\def\smallnominalsize{9pt}
+\setfont\smallrm\rmshape{9}{1000}{OT1}
+\setfont\smalltt\ttshape{9}{1000}{OT1TT}
+\setfont\smallbf\bfshape{10}{900}{OT1}
+\setfont\smallit\itshape{9}{1000}{OT1IT}
+\setfont\smallsl\slshape{9}{1000}{OT1}
+\setfont\smallsf\sfshape{9}{1000}{OT1}
+\setfont\smallsc\scshape{10}{900}{OT1}
+\setfont\smallttsl\ttslshape{10}{900}{OT1TT}
+\font\smalli=cmmi9
+\font\smallsy=cmsy9
+\def\smallecsize{0900}
+
+% Fonts for small examples (8pt).
+\def\smallernominalsize{8pt}
+\setfont\smallerrm\rmshape{8}{1000}{OT1}
+\setfont\smallertt\ttshape{8}{1000}{OT1TT}
+\setfont\smallerbf\bfshape{10}{800}{OT1}
+\setfont\smallerit\itshape{8}{1000}{OT1IT}
+\setfont\smallersl\slshape{8}{1000}{OT1}
+\setfont\smallersf\sfshape{8}{1000}{OT1}
+\setfont\smallersc\scshape{10}{800}{OT1}
+\setfont\smallerttsl\ttslshape{10}{800}{OT1TT}
+\font\smalleri=cmmi8
+\font\smallersy=cmsy8
+\def\smallerecsize{0800}
+
+% Fonts for title page (20.4pt):
+\def\titlenominalsize{20pt}
+\setfont\titlerm\rmbshape{12}{\magstep3}{OT1}
+\setfont\titleit\itbshape{10}{\magstep4}{OT1IT}
+\setfont\titlesl\slbshape{10}{\magstep4}{OT1}
+\setfont\titlett\ttbshape{12}{\magstep3}{OT1TT}
+\setfont\titlettsl\ttslshape{10}{\magstep4}{OT1TT}
+\setfont\titlesf\sfbshape{17}{\magstep1}{OT1}
+\let\titlebf=\titlerm
+\setfont\titlesc\scbshape{10}{\magstep4}{OT1}
+\font\titlei=cmmi12 scaled \magstep3
+\font\titlesy=cmsy10 scaled \magstep4
+\def\authorrm{\secrm}
+\def\authortt{\sectt}
+\def\titleecsize{2074}
+
+% Chapter (and unnumbered) fonts (17.28pt).
+\def\chapnominalsize{17pt}
+\setfont\chaprm\rmbshape{12}{\magstep2}{OT1}
+\setfont\chapit\itbshape{10}{\magstep3}{OT1IT}
+\setfont\chapsl\slbshape{10}{\magstep3}{OT1}
+\setfont\chaptt\ttbshape{12}{\magstep2}{OT1TT}
+\setfont\chapttsl\ttslshape{10}{\magstep3}{OT1TT}
+\setfont\chapsf\sfbshape{17}{1000}{OT1}
+\let\chapbf=\chaprm
+\setfont\chapsc\scbshape{10}{\magstep3}{OT1}
+\font\chapi=cmmi12 scaled \magstep2
+\font\chapsy=cmsy10 scaled \magstep3
+\def\chapecsize{1728}
+
+% Section fonts (14.4pt).
+\def\secnominalsize{14pt}
+\setfont\secrm\rmbshape{12}{\magstep1}{OT1}
+\setfont\secit\itbshape{10}{\magstep2}{OT1IT}
+\setfont\secsl\slbshape{10}{\magstep2}{OT1}
+\setfont\sectt\ttbshape{12}{\magstep1}{OT1TT}
+\setfont\secttsl\ttslshape{10}{\magstep2}{OT1TT}
+\setfont\secsf\sfbshape{12}{\magstep1}{OT1}
+\let\secbf\secrm
+\setfont\secsc\scbshape{10}{\magstep2}{OT1}
+\font\seci=cmmi12 scaled \magstep1
+\font\secsy=cmsy10 scaled \magstep2
+\def\sececsize{1440}
+
+% Subsection fonts (13.15pt).
+\def\ssecnominalsize{13pt}
+\setfont\ssecrm\rmbshape{12}{\magstephalf}{OT1}
+\setfont\ssecit\itbshape{10}{1315}{OT1IT}
+\setfont\ssecsl\slbshape{10}{1315}{OT1}
+\setfont\ssectt\ttbshape{12}{\magstephalf}{OT1TT}
+\setfont\ssecttsl\ttslshape{10}{1315}{OT1TT}
+\setfont\ssecsf\sfbshape{12}{\magstephalf}{OT1}
+\let\ssecbf\ssecrm
+\setfont\ssecsc\scbshape{10}{1315}{OT1}
+\font\sseci=cmmi12 scaled \magstephalf
+\font\ssecsy=cmsy10 scaled 1315
+\def\ssececsize{1200}
+
+% Reduced fonts for @acro in text (10pt).
+\def\reducednominalsize{10pt}
+\setfont\reducedrm\rmshape{10}{1000}{OT1}
+\setfont\reducedtt\ttshape{10}{1000}{OT1TT}
+\setfont\reducedbf\bfshape{10}{1000}{OT1}
+\setfont\reducedit\itshape{10}{1000}{OT1IT}
+\setfont\reducedsl\slshape{10}{1000}{OT1}
+\setfont\reducedsf\sfshape{10}{1000}{OT1}
+\setfont\reducedsc\scshape{10}{1000}{OT1}
+\setfont\reducedttsl\ttslshape{10}{1000}{OT1TT}
+\font\reducedi=cmmi10
+\font\reducedsy=cmsy10
+\def\reducedecsize{1000}
+
+% reset the current fonts
+\textfonts
+\rm
+} % end of 11pt text font size definitions
+
+
+% Definitions to make the main text be 10pt Computer Modern, with
+% section, chapter, etc., sizes following suit. This is for the GNU
+% Press printing of the Emacs 22 manual. Maybe other manuals in the
+% future. Used with @smallbook, which sets the leading to 12pt.
+%
+\def\definetextfontsizex{%
+% Text fonts (10pt).
+\def\textnominalsize{10pt}
+\edef\mainmagstep{1000}
+\setfont\textrm\rmshape{10}{\mainmagstep}{OT1}
+\setfont\texttt\ttshape{10}{\mainmagstep}{OT1TT}
+\setfont\textbf\bfshape{10}{\mainmagstep}{OT1}
+\setfont\textit\itshape{10}{\mainmagstep}{OT1IT}
+\setfont\textsl\slshape{10}{\mainmagstep}{OT1}
+\setfont\textsf\sfshape{10}{\mainmagstep}{OT1}
+\setfont\textsc\scshape{10}{\mainmagstep}{OT1}
+\setfont\textttsl\ttslshape{10}{\mainmagstep}{OT1TT}
+\font\texti=cmmi10 scaled \mainmagstep
+\font\textsy=cmsy10 scaled \mainmagstep
+\def\textecsize{1000}
+
+% A few fonts for @defun names and args.
+\setfont\defbf\bfshape{10}{\magstephalf}{OT1}
+\setfont\deftt\ttshape{10}{\magstephalf}{OT1TT}
+\setfont\defttsl\ttslshape{10}{\magstephalf}{OT1TT}
+\def\df{\let\tentt=\deftt \let\tenbf = \defbf \let\tenttsl=\defttsl \bf}
+
+% Fonts for indices, footnotes, small examples (9pt).
+\def\smallnominalsize{9pt}
+\setfont\smallrm\rmshape{9}{1000}{OT1}
+\setfont\smalltt\ttshape{9}{1000}{OT1TT}
+\setfont\smallbf\bfshape{10}{900}{OT1}
+\setfont\smallit\itshape{9}{1000}{OT1IT}
+\setfont\smallsl\slshape{9}{1000}{OT1}
+\setfont\smallsf\sfshape{9}{1000}{OT1}
+\setfont\smallsc\scshape{10}{900}{OT1}
+\setfont\smallttsl\ttslshape{10}{900}{OT1TT}
+\font\smalli=cmmi9
+\font\smallsy=cmsy9
+\def\smallecsize{0900}
+
+% Fonts for small examples (8pt).
+\def\smallernominalsize{8pt}
+\setfont\smallerrm\rmshape{8}{1000}{OT1}
+\setfont\smallertt\ttshape{8}{1000}{OT1TT}
+\setfont\smallerbf\bfshape{10}{800}{OT1}
+\setfont\smallerit\itshape{8}{1000}{OT1IT}
+\setfont\smallersl\slshape{8}{1000}{OT1}
+\setfont\smallersf\sfshape{8}{1000}{OT1}
+\setfont\smallersc\scshape{10}{800}{OT1}
+\setfont\smallerttsl\ttslshape{10}{800}{OT1TT}
+\font\smalleri=cmmi8
+\font\smallersy=cmsy8
+\def\smallerecsize{0800}
+
+% Fonts for title page (20.4pt):
+\def\titlenominalsize{20pt}
+\setfont\titlerm\rmbshape{12}{\magstep3}{OT1}
+\setfont\titleit\itbshape{10}{\magstep4}{OT1IT}
+\setfont\titlesl\slbshape{10}{\magstep4}{OT1}
+\setfont\titlett\ttbshape{12}{\magstep3}{OT1TT}
+\setfont\titlettsl\ttslshape{10}{\magstep4}{OT1TT}
+\setfont\titlesf\sfbshape{17}{\magstep1}{OT1}
+\let\titlebf=\titlerm
+\setfont\titlesc\scbshape{10}{\magstep4}{OT1}
+\font\titlei=cmmi12 scaled \magstep3
+\font\titlesy=cmsy10 scaled \magstep4
+\def\authorrm{\secrm}
+\def\authortt{\sectt}
+\def\titleecsize{2074}
+
+% Chapter fonts (14.4pt).
+\def\chapnominalsize{14pt}
+\setfont\chaprm\rmbshape{12}{\magstep1}{OT1}
+\setfont\chapit\itbshape{10}{\magstep2}{OT1IT}
+\setfont\chapsl\slbshape{10}{\magstep2}{OT1}
+\setfont\chaptt\ttbshape{12}{\magstep1}{OT1TT}
+\setfont\chapttsl\ttslshape{10}{\magstep2}{OT1TT}
+\setfont\chapsf\sfbshape{12}{\magstep1}{OT1}
+\let\chapbf\chaprm
+\setfont\chapsc\scbshape{10}{\magstep2}{OT1}
+\font\chapi=cmmi12 scaled \magstep1
+\font\chapsy=cmsy10 scaled \magstep2
+\def\chapecsize{1440}
+
+% Section fonts (12pt).
+\def\secnominalsize{12pt}
+\setfont\secrm\rmbshape{12}{1000}{OT1}
+\setfont\secit\itbshape{10}{\magstep1}{OT1IT}
+\setfont\secsl\slbshape{10}{\magstep1}{OT1}
+\setfont\sectt\ttbshape{12}{1000}{OT1TT}
+\setfont\secttsl\ttslshape{10}{\magstep1}{OT1TT}
+\setfont\secsf\sfbshape{12}{1000}{OT1}
+\let\secbf\secrm
+\setfont\secsc\scbshape{10}{\magstep1}{OT1}
+\font\seci=cmmi12
+\font\secsy=cmsy10 scaled \magstep1
+\def\sececsize{1200}
+
+% Subsection fonts (10pt).
+\def\ssecnominalsize{10pt}
+\setfont\ssecrm\rmbshape{10}{1000}{OT1}
+\setfont\ssecit\itbshape{10}{1000}{OT1IT}
+\setfont\ssecsl\slbshape{10}{1000}{OT1}
+\setfont\ssectt\ttbshape{10}{1000}{OT1TT}
+\setfont\ssecttsl\ttslshape{10}{1000}{OT1TT}
+\setfont\ssecsf\sfbshape{10}{1000}{OT1}
+\let\ssecbf\ssecrm
+\setfont\ssecsc\scbshape{10}{1000}{OT1}
+\font\sseci=cmmi10
+\font\ssecsy=cmsy10
+\def\ssececsize{1000}
+
+% Reduced fonts for @acro in text (9pt).
+\def\reducednominalsize{9pt}
+\setfont\reducedrm\rmshape{9}{1000}{OT1}
+\setfont\reducedtt\ttshape{9}{1000}{OT1TT}
+\setfont\reducedbf\bfshape{10}{900}{OT1}
+\setfont\reducedit\itshape{9}{1000}{OT1IT}
+\setfont\reducedsl\slshape{9}{1000}{OT1}
+\setfont\reducedsf\sfshape{9}{1000}{OT1}
+\setfont\reducedsc\scshape{10}{900}{OT1}
+\setfont\reducedttsl\ttslshape{10}{900}{OT1TT}
+\font\reducedi=cmmi9
+\font\reducedsy=cmsy9
+\def\reducedecsize{0900}
+
+% reduce space between paragraphs
+\divide\parskip by 2
+
+% reset the current fonts
+\textfonts
+\rm
+} % end of 10pt text font size definitions
+
+
+% We provide the user-level command
+% @fonttextsize 10
+% (or 11) to redefine the text font size. pt is assumed.
+%
+\def\xword{10}
+\def\xiword{11}
+%
+\parseargdef\fonttextsize{%
+ \def\textsizearg{#1}%
+ \wlog{doing @fonttextsize \textsizearg}%
+ %
+ % Set \globaldefs so that documents can use this inside @tex, since
+ % makeinfo 4.8 does not support it, but we need it nonetheless.
+ %
+ \begingroup \globaldefs=1
+ \ifx\textsizearg\xword \definetextfontsizex
+ \else \ifx\textsizearg\xiword \definetextfontsizexi
+ \else
+ \errhelp=\EMsimple
+ \errmessage{@fonttextsize only supports `10' or `11', not `\textsizearg'}
+ \fi\fi
+ \endgroup
+}
+
+
+% In order for the font changes to affect most math symbols and letters,
+% we have to define the \textfont of the standard families. Since
+% texinfo doesn't allow for producing subscripts and superscripts except
+% in the main text, we don't bother to reset \scriptfont and
+% \scriptscriptfont (which would also require loading a lot more fonts).
+%
+\def\resetmathfonts{%
+ \textfont0=\tenrm \textfont1=\teni \textfont2=\tensy
+ \textfont\itfam=\tenit \textfont\slfam=\tensl \textfont\bffam=\tenbf
+ \textfont\ttfam=\tentt \textfont\sffam=\tensf
+}
+
+% The font-changing commands redefine the meanings of \tenSTYLE, instead
+% of just \STYLE. We do this because \STYLE needs to also set the
+% current \fam for math mode. Our \STYLE (e.g., \rm) commands hardwire
+% \tenSTYLE to set the current font.
+%
+% Each font-changing command also sets the names \lsize (one size lower)
+% and \lllsize (three sizes lower). These relative commands are used in
+% the LaTeX logo and acronyms.
+%
+% This all needs generalizing, badly.
+%
+\def\textfonts{%
+ \let\tenrm=\textrm \let\tenit=\textit \let\tensl=\textsl
+ \let\tenbf=\textbf \let\tentt=\texttt \let\smallcaps=\textsc
+ \let\tensf=\textsf \let\teni=\texti \let\tensy=\textsy
+ \let\tenttsl=\textttsl
+ \def\curfontsize{text}%
+ \def\lsize{reduced}\def\lllsize{smaller}%
+ \resetmathfonts \setleading{\textleading}}
+\def\titlefonts{%
+ \let\tenrm=\titlerm \let\tenit=\titleit \let\tensl=\titlesl
+ \let\tenbf=\titlebf \let\tentt=\titlett \let\smallcaps=\titlesc
+ \let\tensf=\titlesf \let\teni=\titlei \let\tensy=\titlesy
+ \let\tenttsl=\titlettsl
+ \def\curfontsize{title}%
+ \def\lsize{chap}\def\lllsize{subsec}%
+ \resetmathfonts \setleading{25pt}}
+\def\titlefont#1{{\titlefonts\rm #1}}
+\def\chapfonts{%
+ \let\tenrm=\chaprm \let\tenit=\chapit \let\tensl=\chapsl
+ \let\tenbf=\chapbf \let\tentt=\chaptt \let\smallcaps=\chapsc
+ \let\tensf=\chapsf \let\teni=\chapi \let\tensy=\chapsy
+ \let\tenttsl=\chapttsl
+ \def\curfontsize{chap}%
+ \def\lsize{sec}\def\lllsize{text}%
+ \resetmathfonts \setleading{19pt}}
+\def\secfonts{%
+ \let\tenrm=\secrm \let\tenit=\secit \let\tensl=\secsl
+ \let\tenbf=\secbf \let\tentt=\sectt \let\smallcaps=\secsc
+ \let\tensf=\secsf \let\teni=\seci \let\tensy=\secsy
+ \let\tenttsl=\secttsl
+ \def\curfontsize{sec}%
+ \def\lsize{subsec}\def\lllsize{reduced}%
+ \resetmathfonts \setleading{16pt}}
+\def\subsecfonts{%
+ \let\tenrm=\ssecrm \let\tenit=\ssecit \let\tensl=\ssecsl
+ \let\tenbf=\ssecbf \let\tentt=\ssectt \let\smallcaps=\ssecsc
+ \let\tensf=\ssecsf \let\teni=\sseci \let\tensy=\ssecsy
+ \let\tenttsl=\ssecttsl
+ \def\curfontsize{ssec}%
+ \def\lsize{text}\def\lllsize{small}%
+ \resetmathfonts \setleading{15pt}}
+\let\subsubsecfonts = \subsecfonts
+\def\reducedfonts{%
+ \let\tenrm=\reducedrm \let\tenit=\reducedit \let\tensl=\reducedsl
+ \let\tenbf=\reducedbf \let\tentt=\reducedtt \let\reducedcaps=\reducedsc
+ \let\tensf=\reducedsf \let\teni=\reducedi \let\tensy=\reducedsy
+ \let\tenttsl=\reducedttsl
+ \def\curfontsize{reduced}%
+ \def\lsize{small}\def\lllsize{smaller}%
+ \resetmathfonts \setleading{10.5pt}}
+\def\smallfonts{%
+ \let\tenrm=\smallrm \let\tenit=\smallit \let\tensl=\smallsl
+ \let\tenbf=\smallbf \let\tentt=\smalltt \let\smallcaps=\smallsc
+ \let\tensf=\smallsf \let\teni=\smalli \let\tensy=\smallsy
+ \let\tenttsl=\smallttsl
+ \def\curfontsize{small}%
+ \def\lsize{smaller}\def\lllsize{smaller}%
+ \resetmathfonts \setleading{10.5pt}}
+\def\smallerfonts{%
+ \let\tenrm=\smallerrm \let\tenit=\smallerit \let\tensl=\smallersl
+ \let\tenbf=\smallerbf \let\tentt=\smallertt \let\smallcaps=\smallersc
+ \let\tensf=\smallersf \let\teni=\smalleri \let\tensy=\smallersy
+ \let\tenttsl=\smallerttsl
+ \def\curfontsize{smaller}%
+ \def\lsize{smaller}\def\lllsize{smaller}%
+ \resetmathfonts \setleading{9.5pt}}
+
+% Set the fonts to use with the @small... environments.
+\let\smallexamplefonts = \smallfonts
+
+% About \smallexamplefonts. If we use \smallfonts (9pt), @smallexample
+% can fit this many characters:
+% 8.5x11=86 smallbook=72 a4=90 a5=69
+% If we use \scriptfonts (8pt), then we can fit this many characters:
+% 8.5x11=90+ smallbook=80 a4=90+ a5=77
+% For me, subjectively, the few extra characters that fit aren't worth
+% the additional smallness of 8pt. So I'm making the default 9pt.
+%
+% By the way, for comparison, here's what fits with @example (10pt):
+% 8.5x11=71 smallbook=60 a4=75 a5=58
+%
+% I wish the USA used A4 paper.
+% --karl, 24jan03.
+
+
+% Set up the default fonts, so we can use them for creating boxes.
+%
+\definetextfontsizexi
+
+% Define these so they can be easily changed for other fonts.
+\def\angleleft{$\langle$}
+\def\angleright{$\rangle$}
+
+% Count depth in font-changes, for error checks
+\newcount\fontdepth \fontdepth=0
+
+% Fonts for short table of contents.
+\setfont\shortcontrm\rmshape{12}{1000}{OT1}
+\setfont\shortcontbf\bfshape{10}{\magstep1}{OT1} % no cmb12
+\setfont\shortcontsl\slshape{12}{1000}{OT1}
+\setfont\shortconttt\ttshape{12}{1000}{OT1TT}
+
+%% Add scribe-like font environments, plus @l for inline lisp (usually sans
+%% serif) and @ii for TeX italic
+
+% \smartitalic{ARG} outputs arg in italics, followed by an italic correction
+% unless the following character is such as not to need one.
+\def\smartitalicx{\ifx\next,\else\ifx\next-\else\ifx\next.\else
+ \ptexslash\fi\fi\fi}
+\def\smartslanted#1{{\ifusingtt\ttsl\sl #1}\futurelet\next\smartitalicx}
+\def\smartitalic#1{{\ifusingtt\ttsl\it #1}\futurelet\next\smartitalicx}
+
+% like \smartslanted except unconditionally uses \ttsl.
+% @var is set to this for defun arguments.
+\def\ttslanted#1{{\ttsl #1}\futurelet\next\smartitalicx}
+
+% like \smartslanted except unconditionally use \sl. We never want
+% ttsl for book titles, do we?
+\def\cite#1{{\sl #1}\futurelet\next\smartitalicx}
+
+\let\i=\smartitalic
+\let\slanted=\smartslanted
+\let\var=\smartslanted
+\let\dfn=\smartslanted
+\let\emph=\smartitalic
+
+% @b, explicit bold.
+\def\b#1{{\bf #1}}
+\let\strong=\b
+
+% @sansserif, explicit sans.
+\def\sansserif#1{{\sf #1}}
+
+% We can't just use \exhyphenpenalty, because that only has effect at
+% the end of a paragraph. Restore normal hyphenation at the end of the
+% group within which \nohyphenation is presumably called.
+%
+\def\nohyphenation{\hyphenchar\font = -1 \aftergroup\restorehyphenation}
+\def\restorehyphenation{\hyphenchar\font = `- }
+
+% Set sfcode to normal for the chars that usually have another value.
+% Can't use plain's \frenchspacing because it uses the `\x notation, and
+% sometimes \x has an active definition that messes things up.
+%
+\catcode`@=11
+ \def\plainfrenchspacing{%
+ \sfcode\dotChar =\@m \sfcode\questChar=\@m \sfcode\exclamChar=\@m
+ \sfcode\colonChar=\@m \sfcode\semiChar =\@m \sfcode\commaChar =\@m
+ \def\endofsentencespacefactor{1000}% for @. and friends
+ }
+ \def\plainnonfrenchspacing{%
+ \sfcode`\.3000\sfcode`\?3000\sfcode`\!3000
+ \sfcode`\:2000\sfcode`\;1500\sfcode`\,1250
+ \def\endofsentencespacefactor{3000}% for @. and friends
+ }
+\catcode`@=\other
+\def\endofsentencespacefactor{3000}% default
+
+\def\t#1{%
+ {\tt \rawbackslash \plainfrenchspacing #1}%
+ \null
+}
+\def\samp#1{`\tclose{#1}'\null}
+\setfont\keyrm\rmshape{8}{1000}{OT1}
+\font\keysy=cmsy9
+\def\key#1{{\keyrm\textfont2=\keysy \leavevmode\hbox{%
+ \raise0.4pt\hbox{\angleleft}\kern-.08em\vtop{%
+ \vbox{\hrule\kern-0.4pt
+ \hbox{\raise0.4pt\hbox{\vphantom{\angleleft}}#1}}%
+ \kern-0.4pt\hrule}%
+ \kern-.06em\raise0.4pt\hbox{\angleright}}}}
+\def\key #1{{\nohyphenation \uppercase{#1}}\null}
+% The old definition, with no lozenge:
+%\def\key #1{{\ttsl \nohyphenation \uppercase{#1}}\null}
+\def\ctrl #1{{\tt \rawbackslash \hat}#1}
+
+% @file, @option are the same as @samp.
+\let\file=\samp
+\let\option=\samp
+
+% @code is a modification of @t,
+% which makes spaces the same size as normal in the surrounding text.
+\def\tclose#1{%
+ {%
+ % Change normal interword space to be same as for the current font.
+ \spaceskip = \fontdimen2\font
+ %
+ % Switch to typewriter.
+ \tt
+ %
+ % But `\ ' produces the large typewriter interword space.
+ \def\ {{\spaceskip = 0pt{} }}%
+ %
+ % Turn off hyphenation.
+ \nohyphenation
+ %
+ \rawbackslash
+ \plainfrenchspacing
+ #1%
+ }%
+ \null
+}
+
+% We *must* turn on hyphenation at `-' and `_' in @code.
+% Otherwise, it is too hard to avoid overfull hboxes
+% in the Emacs manual, the Library manual, etc.
+
+% Unfortunately, TeX uses one parameter (\hyphenchar) to control
+% both hyphenation at - and hyphenation within words.
+% We must therefore turn them both off (\tclose does that)
+% and arrange explicitly to hyphenate at a dash.
+% -- rms.
+{
+ \catcode`\-=\active \catcode`\_=\active
+ \catcode`\'=\active \catcode`\`=\active
+ %
+ \global\def\code{\begingroup
+ \catcode\rquoteChar=\active \catcode\lquoteChar=\active
+ \let'\codequoteright \let`\codequoteleft
+ %
+ \catcode\dashChar=\active \catcode\underChar=\active
+ \ifallowcodebreaks
+ \let-\codedash
+ \let_\codeunder
+ \else
+ \let-\realdash
+ \let_\realunder
+ \fi
+ \codex
+ }
+}
+
+\def\realdash{-}
+\def\codedash{-\discretionary{}{}{}}
+\def\codeunder{%
+ % this is all so @math{@code{var_name}+1} can work. In math mode, _
+ % is "active" (mathcode"8000) and \normalunderscore (or \char95, etc.)
+ % will therefore expand the active definition of _, which is us
+ % (inside @code that is), therefore an endless loop.
+ \ifusingtt{\ifmmode
+ \mathchar"075F % class 0=ordinary, family 7=ttfam, pos 0x5F=_.
+ \else\normalunderscore \fi
+ \discretionary{}{}{}}%
+ {\_}%
+}
+\def\codex #1{\tclose{#1}\endgroup}
+
+% An additional complication: the above will allow breaks after, e.g.,
+% each of the four underscores in __typeof__. This is undesirable in
+% some manuals, especially if they don't have long identifiers in
+% general. @allowcodebreaks provides a way to control this.
+%
+\newif\ifallowcodebreaks \allowcodebreakstrue
+
+\def\keywordtrue{true}
+\def\keywordfalse{false}
+
+\parseargdef\allowcodebreaks{%
+ \def\txiarg{#1}%
+ \ifx\txiarg\keywordtrue
+ \allowcodebreakstrue
+ \else\ifx\txiarg\keywordfalse
+ \allowcodebreaksfalse
+ \else
+ \errhelp = \EMsimple
+ \errmessage{Unknown @allowcodebreaks option `\txiarg'}%
+ \fi\fi
+}
+
+% @kbd is like @code, except that if the argument is just one @key command,
+% then @kbd has no effect.
+
+% @kbdinputstyle -- arg is `distinct' (@kbd uses slanted tty font always),
+% `example' (@kbd uses ttsl only inside of @example and friends),
+% or `code' (@kbd uses normal tty font always).
+\parseargdef\kbdinputstyle{%
+ \def\txiarg{#1}%
+ \ifx\txiarg\worddistinct
+ \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\ttsl}%
+ \else\ifx\txiarg\wordexample
+ \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\tt}%
+ \else\ifx\txiarg\wordcode
+ \gdef\kbdexamplefont{\tt}\gdef\kbdfont{\tt}%
+ \else
+ \errhelp = \EMsimple
+ \errmessage{Unknown @kbdinputstyle option `\txiarg'}%
+ \fi\fi\fi
+}
+\def\worddistinct{distinct}
+\def\wordexample{example}
+\def\wordcode{code}
+
+% Default is `distinct.'
+\kbdinputstyle distinct
+
+\def\xkey{\key}
+\def\kbdfoo#1#2#3\par{\def\one{#1}\def\three{#3}\def\threex{??}%
+\ifx\one\xkey\ifx\threex\three \key{#2}%
+\else{\tclose{\kbdfont\look}}\fi
+\else{\tclose{\kbdfont\look}}\fi}
+
+% For @indicateurl, @env, @command quotes seem unnecessary, so use \code.
+\let\indicateurl=\code
+\let\env=\code
+\let\command=\code
+
+% @uref (abbreviation for `urlref') takes an optional (comma-separated)
+% second argument specifying the text to display and an optional third
+% arg as text to display instead of (rather than in addition to) the url
+% itself. First (mandatory) arg is the url. Perhaps eventually put in
+% a hypertex \special here.
+%
+\def\uref#1{\douref #1,,,\finish}
+\def\douref#1,#2,#3,#4\finish{\begingroup
+ \unsepspaces
+ \pdfurl{#1}%
+ \setbox0 = \hbox{\ignorespaces #3}%
+ \ifdim\wd0 > 0pt
+ \unhbox0 % third arg given, show only that
+ \else
+ \setbox0 = \hbox{\ignorespaces #2}%
+ \ifdim\wd0 > 0pt
+ \ifpdf
+ \unhbox0 % PDF: 2nd arg given, show only it
+ \else
+ \unhbox0\ (\code{#1})% DVI: 2nd arg given, show both it and url
+ \fi
+ \else
+ \code{#1}% only url given, so show it
+ \fi
+ \fi
+ \endlink
+\endgroup}
+
+% @url synonym for @uref, since that's how everyone uses it.
+%
+\let\url=\uref
+
+% rms does not like angle brackets --karl, 17may97.
+% So now @email is just like @uref, unless we are pdf.
+%
+%\def\email#1{\angleleft{\tt #1}\angleright}
+\ifpdf
+ \def\email#1{\doemail#1,,\finish}
+ \def\doemail#1,#2,#3\finish{\begingroup
+ \unsepspaces
+ \pdfurl{mailto:#1}%
+ \setbox0 = \hbox{\ignorespaces #2}%
+ \ifdim\wd0>0pt\unhbox0\else\code{#1}\fi
+ \endlink
+ \endgroup}
+\else
+ \let\email=\uref
+\fi
+
+% Check if we are currently using a typewriter font. Since all the
+% Computer Modern typewriter fonts have zero interword stretch (and
+% shrink), and it is reasonable to expect all typewriter fonts to have
+% this property, we can check that font parameter.
+%
+\def\ifmonospace{\ifdim\fontdimen3\font=0pt }
+
+% Typeset a dimension, e.g., `in' or `pt'. The only reason for the
+% argument is to make the input look right: @dmn{pt} instead of @dmn{}pt.
+%
+\def\dmn#1{\thinspace #1}
+
+\def\kbd#1{\def\look{#1}\expandafter\kbdfoo\look??\par}
+
+% @l was never documented to mean ``switch to the Lisp font'',
+% and it is not used as such in any manual I can find. We need it for
+% Polish suppressed-l. --karl, 22sep96.
+%\def\l#1{{\li #1}\null}
+
+% Explicit font changes: @r, @sc, undocumented @ii.
+\def\r#1{{\rm #1}} % roman font
+\def\sc#1{{\smallcaps#1}} % smallcaps font
+\def\ii#1{{\it #1}} % italic font
+
+% @acronym for "FBI", "NATO", and the like.
+% We print this one point size smaller, since it's intended for
+% all-uppercase.
+%
+\def\acronym#1{\doacronym #1,,\finish}
+\def\doacronym#1,#2,#3\finish{%
+ {\selectfonts\lsize #1}%
+ \def\temp{#2}%
+ \ifx\temp\empty \else
+ \space ({\unsepspaces \ignorespaces \temp \unskip})%
+ \fi
+}
+
+% @abbr for "Comput. J." and the like.
+% No font change, but don't do end-of-sentence spacing.
+%
+\def\abbr#1{\doabbr #1,,\finish}
+\def\doabbr#1,#2,#3\finish{%
+ {\plainfrenchspacing #1}%
+ \def\temp{#2}%
+ \ifx\temp\empty \else
+ \space ({\unsepspaces \ignorespaces \temp \unskip})%
+ \fi
+}
+
+% @pounds{} is a sterling sign, which Knuth put in the CM italic font.
+%
+\def\pounds{{\it\$}}
+
+% @euro{} comes from a separate font, depending on the current style.
+% We use the free feym* fonts from the eurosym package by Henrik
+% Theiling, which support regular, slanted, bold and bold slanted (and
+% "outlined" (blackboard board, sort of) versions, which we don't need).
+% It is available from http://www.ctan.org/tex-archive/fonts/eurosym.
+%
+% Although only regular is the truly official Euro symbol, we ignore
+% that. The Euro is designed to be slightly taller than the regular
+% font height.
+%
+% feymr - regular
+% feymo - slanted
+% feybr - bold
+% feybo - bold slanted
+%
+% There is no good (free) typewriter version, to my knowledge.
+% A feymr10 euro is ~7.3pt wide, while a normal cmtt10 char is ~5.25pt wide.
+% Hmm.
+%
+% Also doesn't work in math. Do we need to do math with euro symbols?
+% Hope not.
+%
+%
+\def\euro{{\eurofont e}}
+\def\eurofont{%
+ % We set the font at each command, rather than predefining it in
+ % \textfonts and the other font-switching commands, so that
+ % installations which never need the symbol don't have to have the
+ % font installed.
+ %
+ % There is only one designed size (nominal 10pt), so we always scale
+ % that to the current nominal size.
+ %
+ % By the way, simply using "at 1em" works for cmr10 and the like, but
+ % does not work for cmbx10 and other extended/shrunken fonts.
+ %
+ \def\eurosize{\csname\curfontsize nominalsize\endcsname}%
+ %
+ \ifx\curfontstyle\bfstylename
+ % bold:
+ \font\thiseurofont = \ifusingit{feybo10}{feybr10} at \eurosize
+ \else
+ % regular:
+ \font\thiseurofont = \ifusingit{feymo10}{feymr10} at \eurosize
+ \fi
+ \thiseurofont
+}
+
+% Hacks for glyphs from the EC fonts similar to \euro. We don't
+% use \let for the aliases, because sometimes we redefine the original
+% macro, and the alias should reflect the redefinition.
+\def\guillemetleft{{\ecfont \char"13}}
+\def\guillemotleft{\guillemetleft}
+\def\guillemetright{{\ecfont \char"14}}
+\def\guillemotright{\guillemetright}
+\def\guilsinglleft{{\ecfont \char"0E}}
+\def\guilsinglright{{\ecfont \char"0F}}
+\def\quotedblbase{{\ecfont \char"12}}
+\def\quotesinglbase{{\ecfont \char"0D}}
+%
+\def\ecfont{%
+ % We can't distinguish serif/sanserif and italic/slanted, but this
+ % is used for crude hacks anyway (like adding French and German
+ % quotes to documents typeset with CM, where we lose kerning), so
+ % hopefully nobody will notice/care.
+ \edef\ecsize{\csname\curfontsize ecsize\endcsname}%
+ \edef\nominalsize{\csname\curfontsize nominalsize\endcsname}%
+ \ifx\curfontstyle\bfstylename
+ % bold:
+ \font\thisecfont = ecb\ifusingit{i}{x}\ecsize \space at \nominalsize
+ \else
+ % regular:
+ \font\thisecfont = ec\ifusingit{ti}{rm}\ecsize \space at \nominalsize
+ \fi
+ \thisecfont
+}
+
+% @registeredsymbol - R in a circle. The font for the R should really
+% be smaller yet, but lllsize is the best we can do for now.
+% Adapted from the plain.tex definition of \copyright.
+%
+\def\registeredsymbol{%
+ $^{{\ooalign{\hfil\raise.07ex\hbox{\selectfonts\lllsize R}%
+ \hfil\crcr\Orb}}%
+ }$%
+}
+
+% @textdegree - the normal degrees sign.
+%
+\def\textdegree{$^\circ$}
+
+% Laurent Siebenmann reports \Orb undefined with:
+% Textures 1.7.7 (preloaded format=plain 93.10.14) (68K) 16 APR 2004 02:38
+% so we'll define it if necessary.
+%
+\ifx\Orb\undefined
+\def\Orb{\mathhexbox20D}
+\fi
+
+% Quotes.
+\chardef\quotedblleft="5C
+\chardef\quotedblright=`\"
+\chardef\quoteleft=`\`
+\chardef\quoteright=`\'
+
+
+\message{page headings,}
+
+\newskip\titlepagetopglue \titlepagetopglue = 1.5in
+\newskip\titlepagebottomglue \titlepagebottomglue = 2pc
+
+% First the title page. Must do @settitle before @titlepage.
+\newif\ifseenauthor
+\newif\iffinishedtitlepage
+
+% Do an implicit @contents or @shortcontents after @end titlepage if the
+% user says @setcontentsaftertitlepage or @setshortcontentsaftertitlepage.
+%
+\newif\ifsetcontentsaftertitlepage
+ \let\setcontentsaftertitlepage = \setcontentsaftertitlepagetrue
+\newif\ifsetshortcontentsaftertitlepage
+ \let\setshortcontentsaftertitlepage = \setshortcontentsaftertitlepagetrue
+
+\parseargdef\shorttitlepage{\begingroup\hbox{}\vskip 1.5in \chaprm \centerline{#1}%
+ \endgroup\page\hbox{}\page}
+
+\envdef\titlepage{%
+ % Open one extra group, as we want to close it in the middle of \Etitlepage.
+ \begingroup
+ \parindent=0pt \textfonts
+ % Leave some space at the very top of the page.
+ \vglue\titlepagetopglue
+ % No rule at page bottom unless we print one at the top with @title.
+ \finishedtitlepagetrue
+ %
+ % Most title ``pages'' are actually two pages long, with space
+ % at the top of the second. We don't want the ragged left on the second.
+ \let\oldpage = \page
+ \def\page{%
+ \iffinishedtitlepage\else
+ \finishtitlepage
+ \fi
+ \let\page = \oldpage
+ \page
+ \null
+ }%
+}
+
+\def\Etitlepage{%
+ \iffinishedtitlepage\else
+ \finishtitlepage
+ \fi
+ % It is important to do the page break before ending the group,
+ % because the headline and footline are only empty inside the group.
+ % If we use the new definition of \page, we always get a blank page
+ % after the title page, which we certainly don't want.
+ \oldpage
+ \endgroup
+ %
+ % Need this before the \...aftertitlepage checks so that if they are
+ % in effect the toc pages will come out with page numbers.
+ \HEADINGSon
+ %
+ % If they want short, they certainly want long too.
+ \ifsetshortcontentsaftertitlepage
+ \shortcontents
+ \contents
+ \global\let\shortcontents = \relax
+ \global\let\contents = \relax
+ \fi
+ %
+ \ifsetcontentsaftertitlepage
+ \contents
+ \global\let\contents = \relax
+ \global\let\shortcontents = \relax
+ \fi
+}
+
+\def\finishtitlepage{%
+ \vskip4pt \hrule height 2pt width \hsize
+ \vskip\titlepagebottomglue
+ \finishedtitlepagetrue
+}
+
+%%% Macros to be used within @titlepage:
+
+\let\subtitlerm=\tenrm
+\def\subtitlefont{\subtitlerm \normalbaselineskip = 13pt \normalbaselines}
+
+\def\authorfont{\authorrm \normalbaselineskip = 16pt \normalbaselines
+ \let\tt=\authortt}
+
+\parseargdef\title{%
+ \checkenv\titlepage
+ \leftline{\titlefonts\rm #1}
+ % print a rule at the page bottom also.
+ \finishedtitlepagefalse
+ \vskip4pt \hrule height 4pt width \hsize \vskip4pt
+}
+
+\parseargdef\subtitle{%
+ \checkenv\titlepage
+ {\subtitlefont \rightline{#1}}%
+}
+
+% @author should come last, but may come many times.
+% It can also be used inside @quotation.
+%
+\parseargdef\author{%
+ \def\temp{\quotation}%
+ \ifx\thisenv\temp
+ \def\quotationauthor{#1}% printed in \Equotation.
+ \else
+ \checkenv\titlepage
+ \ifseenauthor\else \vskip 0pt plus 1filll \seenauthortrue \fi
+ {\authorfont \leftline{#1}}%
+ \fi
+}
+
+
+%%% Set up page headings and footings.
+
+\let\thispage=\folio
+
+\newtoks\evenheadline % headline on even pages
+\newtoks\oddheadline % headline on odd pages
+\newtoks\evenfootline % footline on even pages
+\newtoks\oddfootline % footline on odd pages
+
+% Now make TeX use those variables
+\headline={{\textfonts\rm \ifodd\pageno \the\oddheadline
+ \else \the\evenheadline \fi}}
+\footline={{\textfonts\rm \ifodd\pageno \the\oddfootline
+ \else \the\evenfootline \fi}\HEADINGShook}
+\let\HEADINGShook=\relax
+
+% Commands to set those variables.
+% For example, this is what @headings on does
+% @evenheading @thistitle|@thispage|@thischapter
+% @oddheading @thischapter|@thispage|@thistitle
+% @evenfooting @thisfile||
+% @oddfooting ||@thisfile
+
+
+\def\evenheading{\parsearg\evenheadingxxx}
+\def\evenheadingxxx #1{\evenheadingyyy #1\|\|\|\|\finish}
+\def\evenheadingyyy #1\|#2\|#3\|#4\finish{%
+\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
+
+\def\oddheading{\parsearg\oddheadingxxx}
+\def\oddheadingxxx #1{\oddheadingyyy #1\|\|\|\|\finish}
+\def\oddheadingyyy #1\|#2\|#3\|#4\finish{%
+\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
+
+\parseargdef\everyheading{\oddheadingxxx{#1}\evenheadingxxx{#1}}%
+
+\def\evenfooting{\parsearg\evenfootingxxx}
+\def\evenfootingxxx #1{\evenfootingyyy #1\|\|\|\|\finish}
+\def\evenfootingyyy #1\|#2\|#3\|#4\finish{%
+\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
+
+\def\oddfooting{\parsearg\oddfootingxxx}
+\def\oddfootingxxx #1{\oddfootingyyy #1\|\|\|\|\finish}
+\def\oddfootingyyy #1\|#2\|#3\|#4\finish{%
+ \global\oddfootline = {\rlap{\centerline{#2}}\line{#1\hfil#3}}%
+ %
+ % Leave some space for the footline. Hopefully ok to assume
+ % @evenfooting will not be used by itself.
+ \global\advance\pageheight by -12pt
+ \global\advance\vsize by -12pt
+}
+
+\parseargdef\everyfooting{\oddfootingxxx{#1}\evenfootingxxx{#1}}
+
+% @evenheadingmarks top \thischapter <- chapter at the top of a page
+% @evenheadingmarks bottom \thischapter <- chapter at the bottom of a page
+%
+% The same set of arguments for:
+%
+% @oddheadingmarks
+% @evenfootingmarks
+% @oddfootingmarks
+% @everyheadingmarks
+% @everyfootingmarks
+
+\def\evenheadingmarks{\headingmarks{even}{heading}}
+\def\oddheadingmarks{\headingmarks{odd}{heading}}
+\def\evenfootingmarks{\headingmarks{even}{footing}}
+\def\oddfootingmarks{\headingmarks{odd}{footing}}
+\def\everyheadingmarks#1 {\headingmarks{even}{heading}{#1}
+ \headingmarks{odd}{heading}{#1} }
+\def\everyfootingmarks#1 {\headingmarks{even}{footing}{#1}
+ \headingmarks{odd}{footing}{#1} }
+% #1 = even/odd, #2 = heading/footing, #3 = top/bottom.
+\def\headingmarks#1#2#3 {%
+ \expandafter\let\expandafter\temp \csname get#3headingmarks\endcsname
+ \global\expandafter\let\csname get#1#2marks\endcsname \temp
+}
+
+\everyheadingmarks bottom
+\everyfootingmarks bottom
+
+% @headings double turns headings on for double-sided printing.
+% @headings single turns headings on for single-sided printing.
+% @headings off turns them off.
+% @headings on same as @headings double, retained for compatibility.
+% @headings after turns on double-sided headings after this page.
+% @headings doubleafter turns on double-sided headings after this page.
+% @headings singleafter turns on single-sided headings after this page.
+% By default, they are off at the start of a document,
+% and turned `on' after @end titlepage.
+
+\def\headings #1 {\csname HEADINGS#1\endcsname}
+
+\def\HEADINGSoff{%
+\global\evenheadline={\hfil} \global\evenfootline={\hfil}
+\global\oddheadline={\hfil} \global\oddfootline={\hfil}}
+\HEADINGSoff
+% When we turn headings on, set the page number to 1.
+% For double-sided printing, put current file name in lower left corner,
+% chapter name on inside top of right hand pages, document
+% title on inside top of left hand pages, and page numbers on outside top
+% edge of all pages.
+\def\HEADINGSdouble{%
+\global\pageno=1
+\global\evenfootline={\hfil}
+\global\oddfootline={\hfil}
+\global\evenheadline={\line{\folio\hfil\thistitle}}
+\global\oddheadline={\line{\thischapter\hfil\folio}}
+\global\let\contentsalignmacro = \chapoddpage
+}
+\let\contentsalignmacro = \chappager
+
+% For single-sided printing, chapter title goes across top left of page,
+% page number on top right.
+\def\HEADINGSsingle{%
+\global\pageno=1
+\global\evenfootline={\hfil}
+\global\oddfootline={\hfil}
+\global\evenheadline={\line{\thischapter\hfil\folio}}
+\global\oddheadline={\line{\thischapter\hfil\folio}}
+\global\let\contentsalignmacro = \chappager
+}
+\def\HEADINGSon{\HEADINGSdouble}
+
+\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex}
+\let\HEADINGSdoubleafter=\HEADINGSafter
+\def\HEADINGSdoublex{%
+\global\evenfootline={\hfil}
+\global\oddfootline={\hfil}
+\global\evenheadline={\line{\folio\hfil\thistitle}}
+\global\oddheadline={\line{\thischapter\hfil\folio}}
+\global\let\contentsalignmacro = \chapoddpage
+}
+
+\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex}
+\def\HEADINGSsinglex{%
+\global\evenfootline={\hfil}
+\global\oddfootline={\hfil}
+\global\evenheadline={\line{\thischapter\hfil\folio}}
+\global\oddheadline={\line{\thischapter\hfil\folio}}
+\global\let\contentsalignmacro = \chappager
+}
+
+% Subroutines used in generating headings
+% This produces Day Month Year style of output.
+% Only define if not already defined, in case a txi-??.tex file has set
+% up a different format (e.g., txi-cs.tex does this).
+\ifx\today\undefined
+\def\today{%
+ \number\day\space
+ \ifcase\month
+ \or\putwordMJan\or\putwordMFeb\or\putwordMMar\or\putwordMApr
+ \or\putwordMMay\or\putwordMJun\or\putwordMJul\or\putwordMAug
+ \or\putwordMSep\or\putwordMOct\or\putwordMNov\or\putwordMDec
+ \fi
+ \space\number\year}
+\fi
+
+% @settitle line... specifies the title of the document, for headings.
+% It generates no output of its own.
+\def\thistitle{\putwordNoTitle}
+\def\settitle{\parsearg{\gdef\thistitle}}
+
+
+\message{tables,}
+% Tables -- @table, @ftable, @vtable, @item(x).
+
+% default indentation of table text
+\newdimen\tableindent \tableindent=.8in
+% default indentation of @itemize and @enumerate text
+\newdimen\itemindent \itemindent=.3in
+% margin between end of table item and start of table text.
+\newdimen\itemmargin \itemmargin=.1in
+
+% used internally for \itemindent minus \itemmargin
+\newdimen\itemmax
+
+% Note @table, @ftable, and @vtable define @item, @itemx, etc., with
+% these defs.
+% They also define \itemindex
+% to index the item name in whatever manner is desired (perhaps none).
+
+\newif\ifitemxneedsnegativevskip
+
+\def\itemxpar{\par\ifitemxneedsnegativevskip\nobreak\vskip-\parskip\nobreak\fi}
+
+\def\internalBitem{\smallbreak \parsearg\itemzzz}
+\def\internalBitemx{\itemxpar \parsearg\itemzzz}
+
+\def\itemzzz #1{\begingroup %
+ \advance\hsize by -\rightskip
+ \advance\hsize by -\tableindent
+ \setbox0=\hbox{\itemindicate{#1}}%
+ \itemindex{#1}%
+ \nobreak % This prevents a break before @itemx.
+ %
+ % If the item text does not fit in the space we have, put it on a line
+ % by itself, and do not allow a page break either before or after that
+ % line. We do not start a paragraph here because then if the next
+ % command is, e.g., @kindex, the whatsit would get put into the
+ % horizontal list on a line by itself, resulting in extra blank space.
+ \ifdim \wd0>\itemmax
+ %
+ % Make this a paragraph so we get the \parskip glue and wrapping,
+ % but leave it ragged-right.
+ \begingroup
+ \advance\leftskip by-\tableindent
+ \advance\hsize by\tableindent
+ \advance\rightskip by0pt plus1fil
+ \leavevmode\unhbox0\par
+ \endgroup
+ %
+ % We're going to be starting a paragraph, but we don't want the
+ % \parskip glue -- logically it's part of the @item we just started.
+ \nobreak \vskip-\parskip
+ %
+ % Stop a page break at the \parskip glue coming up. However, if
+ % what follows is an environment such as @example, there will be no
+ % \parskip glue; then the negative vskip we just inserted would
+ % cause the example and the item to crash together. So we use this
+ % bizarre value of 10001 as a signal to \aboveenvbreak to insert
+ % \parskip glue after all. Section titles are handled this way also.
+ %
+ \penalty 10001
+ \endgroup
+ \itemxneedsnegativevskipfalse
+ \else
+ % The item text fits into the space. Start a paragraph, so that the
+ % following text (if any) will end up on the same line.
+ \noindent
+ % Do this with kerns and \unhbox so that if there is a footnote in
+ % the item text, it can migrate to the main vertical list and
+ % eventually be printed.
+ \nobreak\kern-\tableindent
+ \dimen0 = \itemmax \advance\dimen0 by \itemmargin \advance\dimen0 by -\wd0
+ \unhbox0
+ \nobreak\kern\dimen0
+ \endgroup
+ \itemxneedsnegativevskiptrue
+ \fi
+}
+
+\def\item{\errmessage{@item while not in a list environment}}
+\def\itemx{\errmessage{@itemx while not in a list environment}}
+
+% @table, @ftable, @vtable.
+\envdef\table{%
+ \let\itemindex\gobble
+ \tablecheck{table}%
+}
+\envdef\ftable{%
+ \def\itemindex ##1{\doind {fn}{\code{##1}}}%
+ \tablecheck{ftable}%
+}
+\envdef\vtable{%
+ \def\itemindex ##1{\doind {vr}{\code{##1}}}%
+ \tablecheck{vtable}%
+}
+\def\tablecheck#1{%
+ \ifnum \the\catcode`\^^M=\active
+ \endgroup
+ \errmessage{This command won't work in this context; perhaps the problem is
+ that we are \inenvironment\thisenv}%
+ \def\next{\doignore{#1}}%
+ \else
+ \let\next\tablex
+ \fi
+ \next
+}
+\def\tablex#1{%
+ \def\itemindicate{#1}%
+ \parsearg\tabley
+}
+\def\tabley#1{%
+ {%
+ \makevalueexpandable
+ \edef\temp{\noexpand\tablez #1\space\space\space}%
+ \expandafter
+ }\temp \endtablez
+}
+\def\tablez #1 #2 #3 #4\endtablez{%
+ \aboveenvbreak
+ \ifnum 0#1>0 \advance \leftskip by #1\mil \fi
+ \ifnum 0#2>0 \tableindent=#2\mil \fi
+ \ifnum 0#3>0 \advance \rightskip by #3\mil \fi
+ \itemmax=\tableindent
+ \advance \itemmax by -\itemmargin
+ \advance \leftskip by \tableindent
+ \exdentamount=\tableindent
+ \parindent = 0pt
+ \parskip = \smallskipamount
+ \ifdim \parskip=0pt \parskip=2pt \fi
+ \let\item = \internalBitem
+ \let\itemx = \internalBitemx
+}
+\def\Etable{\endgraf\afterenvbreak}
+\let\Eftable\Etable
+\let\Evtable\Etable
+\let\Eitemize\Etable
+\let\Eenumerate\Etable
+
+% This is the counter used by @enumerate, which is really @itemize
+
+\newcount \itemno
+
+\envdef\itemize{\parsearg\doitemize}
+
+\def\doitemize#1{%
+ \aboveenvbreak
+ \itemmax=\itemindent
+ \advance\itemmax by -\itemmargin
+ \advance\leftskip by \itemindent
+ \exdentamount=\itemindent
+ \parindent=0pt
+ \parskip=\smallskipamount
+ \ifdim\parskip=0pt \parskip=2pt \fi
+ \def\itemcontents{#1}%
+ % @itemize with no arg is equivalent to @itemize @bullet.
+ \ifx\itemcontents\empty\def\itemcontents{\bullet}\fi
+ \let\item=\itemizeitem
+}
+
+% Definition of @item while inside @itemize and @enumerate.
+%
+\def\itemizeitem{%
+ \advance\itemno by 1 % for enumerations
+ {\let\par=\endgraf \smallbreak}% reasonable place to break
+ {%
+ % If the document has an @itemize directly after a section title, a
+ % \nobreak will be last on the list, and \sectionheading will have
+ % done a \vskip-\parskip. In that case, we don't want to zero
+ % parskip, or the item text will crash with the heading. On the
+ % other hand, when there is normal text preceding the item (as there
+ % usually is), we do want to zero parskip, or there would be too much
+ % space. In that case, we won't have a \nobreak before. At least
+ % that's the theory.
+ \ifnum\lastpenalty<10000 \parskip=0in \fi
+ \noindent
+ \hbox to 0pt{\hss \itemcontents \kern\itemmargin}%
+ \vadjust{\penalty 1200}}% not good to break after first line of item.
+ \flushcr
+}
+
+% \splitoff TOKENS\endmark defines \first to be the first token in
+% TOKENS, and \rest to be the remainder.
+%
+\def\splitoff#1#2\endmark{\def\first{#1}\def\rest{#2}}%
+
+% Allow an optional argument of an uppercase letter, lowercase letter,
+% or number, to specify the first label in the enumerated list. No
+% argument is the same as `1'.
+%
+\envparseargdef\enumerate{\enumeratey #1 \endenumeratey}
+\def\enumeratey #1 #2\endenumeratey{%
+ % If we were given no argument, pretend we were given `1'.
+ \def\thearg{#1}%
+ \ifx\thearg\empty \def\thearg{1}\fi
+ %
+ % Detect if the argument is a single token. If so, it might be a
+ % letter. Otherwise, the only valid thing it can be is a number.
+ % (We will always have one token, because of the test we just made.
+ % This is a good thing, since \splitoff doesn't work given nothing at
+ % all -- the first parameter is undelimited.)
+ \expandafter\splitoff\thearg\endmark
+ \ifx\rest\empty
+ % Only one token in the argument. It could still be anything.
+ % A ``lowercase letter'' is one whose \lccode is nonzero.
+ % An ``uppercase letter'' is one whose \lccode is both nonzero, and
+ % not equal to itself.
+ % Otherwise, we assume it's a number.
+ %
+ % We need the \relax at the end of the \ifnum lines to stop TeX from
+ % continuing to look for a <number>.
+ %
+ \ifnum\lccode\expandafter`\thearg=0\relax
+ \numericenumerate % a number (we hope)
+ \else
+ % It's a letter.
+ \ifnum\lccode\expandafter`\thearg=\expandafter`\thearg\relax
+ \lowercaseenumerate % lowercase letter
+ \else
+ \uppercaseenumerate % uppercase letter
+ \fi
+ \fi
+ \else
+ % Multiple tokens in the argument. We hope it's a number.
+ \numericenumerate
+ \fi
+}
+
+% An @enumerate whose labels are integers. The starting integer is
+% given in \thearg.
+%
+\def\numericenumerate{%
+ \itemno = \thearg
+ \startenumeration{\the\itemno}%
+}
+
+% The starting (lowercase) letter is in \thearg.
+\def\lowercaseenumerate{%
+ \itemno = \expandafter`\thearg
+ \startenumeration{%
+ % Be sure we're not beyond the end of the alphabet.
+ \ifnum\itemno=0
+ \errmessage{No more lowercase letters in @enumerate; get a bigger
+ alphabet}%
+ \fi
+ \char\lccode\itemno
+ }%
+}
+
+% The starting (uppercase) letter is in \thearg.
+\def\uppercaseenumerate{%
+ \itemno = \expandafter`\thearg
+ \startenumeration{%
+ % Be sure we're not beyond the end of the alphabet.
+ \ifnum\itemno=0
+ \errmessage{No more uppercase letters in @enumerate; get a bigger
+ alphabet}
+ \fi
+ \char\uccode\itemno
+ }%
+}
+
+% Call \doitemize, adding a period to the first argument and supplying the
+% common last two arguments. Also subtract one from the initial value in
+% \itemno, since @item increments \itemno.
+%
+\def\startenumeration#1{%
+ \advance\itemno by -1
+ \doitemize{#1.}\flushcr
+}
+
+% @alphaenumerate and @capsenumerate are abbreviations for giving an arg
+% to @enumerate.
+%
+\def\alphaenumerate{\enumerate{a}}
+\def\capsenumerate{\enumerate{A}}
+\def\Ealphaenumerate{\Eenumerate}
+\def\Ecapsenumerate{\Eenumerate}
+
+
+% @multitable macros
+% Amy Hendrickson, 8/18/94, 3/6/96
+%
+% @multitable ... @end multitable will make as many columns as desired.
+% Contents of each column will wrap at width given in preamble. Width
+% can be specified either with sample text given in a template line,
+% or in percent of \hsize, the current width of text on page.
+
+% Table can continue over pages but will only break between lines.
+
+% To make preamble:
+%
+% Either define widths of columns in terms of percent of \hsize:
+% @multitable @columnfractions .25 .3 .45
+% @item ...
+%
+% Numbers following @columnfractions are the percent of the total
+% current hsize to be used for each column. You may use as many
+% columns as desired.
+
+
+% Or use a template:
+% @multitable {Column 1 template} {Column 2 template} {Column 3 template}
+% @item ...
+% using the widest term desired in each column.
+
+% Each new table line starts with @item, each subsequent new column
+% starts with @tab. Empty columns may be produced by supplying @tab's
+% with nothing between them for as many times as empty columns are needed,
+% ie, @tab@tab@tab will produce two empty columns.
+
+% @item, @tab do not need to be on their own lines, but it will not hurt
+% if they are.
+
+% Sample multitable:
+
+% @multitable {Column 1 template} {Column 2 template} {Column 3 template}
+% @item first col stuff @tab second col stuff @tab third col
+% @item
+% first col stuff
+% @tab
+% second col stuff
+% @tab
+% third col
+% @item first col stuff @tab second col stuff
+% @tab Many paragraphs of text may be used in any column.
+%
+% They will wrap at the width determined by the template.
+% @item@tab@tab This will be in third column.
+% @end multitable
+
+% Default dimensions may be reset by user.
+% @multitableparskip is vertical space between paragraphs in table.
+% @multitableparindent is paragraph indent in table.
+% @multitablecolmargin is horizontal space to be left between columns.
+% @multitablelinespace is space to leave between table items, baseline
+% to baseline.
+% 0pt means it depends on current normal line spacing.
+%
+\newskip\multitableparskip
+\newskip\multitableparindent
+\newdimen\multitablecolspace
+\newskip\multitablelinespace
+\multitableparskip=0pt
+\multitableparindent=6pt
+\multitablecolspace=12pt
+\multitablelinespace=0pt
+
+% Macros used to set up halign preamble:
+%
+\let\endsetuptable\relax
+\def\xendsetuptable{\endsetuptable}
+\let\columnfractions\relax
+\def\xcolumnfractions{\columnfractions}
+\newif\ifsetpercent
+
+% #1 is the @columnfraction, usually a decimal number like .5, but might
+% be just 1. We just use it, whatever it is.
+%
+\def\pickupwholefraction#1 {%
+ \global\advance\colcount by 1
+ \expandafter\xdef\csname col\the\colcount\endcsname{#1\hsize}%
+ \setuptable
+}
+
+\newcount\colcount
+\def\setuptable#1{%
+ \def\firstarg{#1}%
+ \ifx\firstarg\xendsetuptable
+ \let\go = \relax
+ \else
+ \ifx\firstarg\xcolumnfractions
+ \global\setpercenttrue
+ \else
+ \ifsetpercent
+ \let\go\pickupwholefraction
+ \else
+ \global\advance\colcount by 1
+ \setbox0=\hbox{#1\unskip\space}% Add a normal word space as a
+ % separator; typically that is always in the input, anyway.
+ \expandafter\xdef\csname col\the\colcount\endcsname{\the\wd0}%
+ \fi
+ \fi
+ \ifx\go\pickupwholefraction
+ % Put the argument back for the \pickupwholefraction call, so
+ % we'll always have a period there to be parsed.
+ \def\go{\pickupwholefraction#1}%
+ \else
+ \let\go = \setuptable
+ \fi%
+ \fi
+ \go
+}
+
+% multitable-only commands.
+%
+% @headitem starts a heading row, which we typeset in bold.
+% Assignments have to be global since we are inside the implicit group
+% of an alignment entry. Note that \everycr resets \everytab.
+\def\headitem{\checkenv\multitable \crcr \global\everytab={\bf}\the\everytab}%
+%
+% A \tab used to include \hskip1sp. But then the space in a template
+% line is not enough. That is bad. So let's go back to just `&' until
+% we encounter the problem it was intended to solve again.
+% --karl, nathan@acm.org, 20apr99.
+\def\tab{\checkenv\multitable &\the\everytab}%
+
+% @multitable ... @end multitable definitions:
+%
+\newtoks\everytab % insert after every tab.
+%
+\envdef\multitable{%
+ \vskip\parskip
+ \startsavinginserts
+ %
+ % @item within a multitable starts a normal row.
+ % We use \def instead of \let so that if one of the multitable entries
+ % contains an @itemize, we don't choke on the \item (seen as \crcr aka
+ % \endtemplate) expanding \doitemize.
+ \def\item{\crcr}%
+ %
+ \tolerance=9500
+ \hbadness=9500
+ \setmultitablespacing
+ \parskip=\multitableparskip
+ \parindent=\multitableparindent
+ \overfullrule=0pt
+ \global\colcount=0
+ %
+ \everycr = {%
+ \noalign{%
+ \global\everytab={}%
+ \global\colcount=0 % Reset the column counter.
+ % Check for saved footnotes, etc.
+ \checkinserts
+ % Keeps underfull box messages off when table breaks over pages.
+ %\filbreak
+ % Maybe so, but it also creates really weird page breaks when the
+ % table breaks over pages. Wouldn't \vfil be better? Wait until the
+ % problem manifests itself, so it can be fixed for real --karl.
+ }%
+ }%
+ %
+ \parsearg\domultitable
+}
+\def\domultitable#1{%
+ % To parse everything between @multitable and @item:
+ \setuptable#1 \endsetuptable
+ %
+ % This preamble sets up a generic column definition, which will
+ % be used as many times as user calls for columns.
+ % \vtop will set a single line and will also let text wrap and
+ % continue for many paragraphs if desired.
+ \halign\bgroup &%
+ \global\advance\colcount by 1
+ \multistrut
+ \vtop{%
+ % Use the current \colcount to find the correct column width:
+ \hsize=\expandafter\csname col\the\colcount\endcsname
+ %
+ % In order to keep entries from bumping into each other
+ % we will add a \leftskip of \multitablecolspace to all columns after
+ % the first one.
+ %
+ % If a template has been used, we will add \multitablecolspace
+ % to the width of each template entry.
+ %
+ % If the user has set preamble in terms of percent of \hsize we will
+ % use that dimension as the width of the column, and the \leftskip
+ % will keep entries from bumping into each other. Table will start at
+ % left margin and final column will justify at right margin.
+ %
+ % Make sure we don't inherit \rightskip from the outer environment.
+ \rightskip=0pt
+ \ifnum\colcount=1
+ % The first column will be indented with the surrounding text.
+ \advance\hsize by\leftskip
+ \else
+ \ifsetpercent \else
+ % If user has not set preamble in terms of percent of \hsize
+ % we will advance \hsize by \multitablecolspace.
+ \advance\hsize by \multitablecolspace
+ \fi
+ % In either case we will make \leftskip=\multitablecolspace:
+ \leftskip=\multitablecolspace
+ \fi
+ % Ignoring space at the beginning and end avoids an occasional spurious
+ % blank line, when TeX decides to break the line at the space before the
+ % box from the multistrut, so the strut ends up on a line by itself.
+ % For example:
+ % @multitable @columnfractions .11 .89
+ % @item @code{#}
+ % @tab Legal holiday which is valid in major parts of the whole country.
+ % Is automatically provided with highlighting sequences respectively
+ % marking characters.
+ \noindent\ignorespaces##\unskip\multistrut
+ }\cr
+}
+\def\Emultitable{%
+ \crcr
+ \egroup % end the \halign
+ \global\setpercentfalse
+}
+
+\def\setmultitablespacing{%
+ \def\multistrut{\strut}% just use the standard line spacing
+ %
+ % Compute \multitablelinespace (if not defined by user) for use in
+ % \multitableparskip calculation. We used define \multistrut based on
+ % this, but (ironically) that caused the spacing to be off.
+ % See bug-texinfo report from Werner Lemberg, 31 Oct 2004 12:52:20 +0100.
+\ifdim\multitablelinespace=0pt
+\setbox0=\vbox{X}\global\multitablelinespace=\the\baselineskip
+\global\advance\multitablelinespace by-\ht0
+\fi
+%% Test to see if parskip is larger than space between lines of
+%% table. If not, do nothing.
+%% If so, set to same dimension as multitablelinespace.
+\ifdim\multitableparskip>\multitablelinespace
+\global\multitableparskip=\multitablelinespace
+\global\advance\multitableparskip-7pt %% to keep parskip somewhat smaller
+ %% than skip between lines in the table.
+\fi%
+\ifdim\multitableparskip=0pt
+\global\multitableparskip=\multitablelinespace
+\global\advance\multitableparskip-7pt %% to keep parskip somewhat smaller
+ %% than skip between lines in the table.
+\fi}
+
+
+\message{conditionals,}
+
+% @iftex, @ifnotdocbook, @ifnothtml, @ifnotinfo, @ifnotplaintext,
+% @ifnotxml always succeed. They currently do nothing; we don't
+% attempt to check whether the conditionals are properly nested. But we
+% have to remember that they are conditionals, so that @end doesn't
+% attempt to close an environment group.
+%
+\def\makecond#1{%
+ \expandafter\let\csname #1\endcsname = \relax
+ \expandafter\let\csname iscond.#1\endcsname = 1
+}
+\makecond{iftex}
+\makecond{ifnotdocbook}
+\makecond{ifnothtml}
+\makecond{ifnotinfo}
+\makecond{ifnotplaintext}
+\makecond{ifnotxml}
+
+% Ignore @ignore, @ifhtml, @ifinfo, and the like.
+%
+\def\direntry{\doignore{direntry}}
+\def\documentdescription{\doignore{documentdescription}}
+\def\docbook{\doignore{docbook}}
+\def\html{\doignore{html}}
+\def\ifdocbook{\doignore{ifdocbook}}
+\def\ifhtml{\doignore{ifhtml}}
+\def\ifinfo{\doignore{ifinfo}}
+\def\ifnottex{\doignore{ifnottex}}
+\def\ifplaintext{\doignore{ifplaintext}}
+\def\ifxml{\doignore{ifxml}}
+\def\ignore{\doignore{ignore}}
+\def\menu{\doignore{menu}}
+\def\xml{\doignore{xml}}
+
+% Ignore text until a line `@end #1', keeping track of nested conditionals.
+%
+% A count to remember the depth of nesting.
+\newcount\doignorecount
+
+\def\doignore#1{\begingroup
+ % Scan in ``verbatim'' mode:
+ \obeylines
+ \catcode`\@ = \other
+ \catcode`\{ = \other
+ \catcode`\} = \other
+ %
+ % Make sure that spaces turn into tokens that match what \doignoretext wants.
+ \spaceisspace
+ %
+ % Count number of #1's that we've seen.
+ \doignorecount = 0
+ %
+ % Swallow text until we reach the matching `@end #1'.
+ \dodoignore{#1}%
+}
+
+{ \catcode`_=11 % We want to use \_STOP_ which cannot appear in texinfo source.
+ \obeylines %
+ %
+ \gdef\dodoignore#1{%
+ % #1 contains the command name as a string, e.g., `ifinfo'.
+ %
+ % Define a command to find the next `@end #1'.
+ \long\def\doignoretext##1^^M@end #1{%
+ \doignoretextyyy##1^^M@#1\_STOP_}%
+ %
+ % And this command to find another #1 command, at the beginning of a
+ % line. (Otherwise, we would consider a line `@c @ifset', for
+ % example, to count as an @ifset for nesting.)
+ \long\def\doignoretextyyy##1^^M@#1##2\_STOP_{\doignoreyyy{##2}\_STOP_}%
+ %
+ % And now expand that command.
+ \doignoretext ^^M%
+ }%
+}
+
+\def\doignoreyyy#1{%
+ \def\temp{#1}%
+ \ifx\temp\empty % Nothing found.
+ \let\next\doignoretextzzz
+ \else % Found a nested condition, ...
+ \advance\doignorecount by 1
+ \let\next\doignoretextyyy % ..., look for another.
+ % If we're here, #1 ends with ^^M\ifinfo (for example).
+ \fi
+ \next #1% the token \_STOP_ is present just after this macro.
+}
+
+% We have to swallow the remaining "\_STOP_".
+%
+\def\doignoretextzzz#1{%
+ \ifnum\doignorecount = 0 % We have just found the outermost @end.
+ \let\next\enddoignore
+ \else % Still inside a nested condition.
+ \advance\doignorecount by -1
+ \let\next\doignoretext % Look for the next @end.
+ \fi
+ \next
+}
+
+% Finish off ignored text.
+{ \obeylines%
+ % Ignore anything after the last `@end #1'; this matters in verbatim
+ % environments, where otherwise the newline after an ignored conditional
+ % would result in a blank line in the output.
+ \gdef\enddoignore#1^^M{\endgroup\ignorespaces}%
+}
+
+
+% @set VAR sets the variable VAR to an empty value.
+% @set VAR REST-OF-LINE sets VAR to the value REST-OF-LINE.
+%
+% Since we want to separate VAR from REST-OF-LINE (which might be
+% empty), we can't just use \parsearg; we have to insert a space of our
+% own to delimit the rest of the line, and then take it out again if we
+% didn't need it.
+% We rely on the fact that \parsearg sets \catcode`\ =10.
+%
+\parseargdef\set{\setyyy#1 \endsetyyy}
+\def\setyyy#1 #2\endsetyyy{%
+ {%
+ \makevalueexpandable
+ \def\temp{#2}%
+ \edef\next{\gdef\makecsname{SET#1}}%
+ \ifx\temp\empty
+ \next{}%
+ \else
+ \setzzz#2\endsetzzz
+ \fi
+ }%
+}
+% Remove the trailing space \setxxx inserted.
+\def\setzzz#1 \endsetzzz{\next{#1}}
+
+% @clear VAR clears (i.e., unsets) the variable VAR.
+%
+\parseargdef\clear{%
+ {%
+ \makevalueexpandable
+ \global\expandafter\let\csname SET#1\endcsname=\relax
+ }%
+}
+
+% @value{foo} gets the text saved in variable foo.
+\def\value{\begingroup\makevalueexpandable\valuexxx}
+\def\valuexxx#1{\expandablevalue{#1}\endgroup}
+{
+ \catcode`\- = \active \catcode`\_ = \active
+ %
+ \gdef\makevalueexpandable{%
+ \let\value = \expandablevalue
+ % We don't want these characters active, ...
+ \catcode`\-=\other \catcode`\_=\other
+ % ..., but we might end up with active ones in the argument if
+ % we're called from @code, as @code{@value{foo-bar_}}, though.
+ % So \let them to their normal equivalents.
+ \let-\realdash \let_\normalunderscore
+ }
+}
+
+% We have this subroutine so that we can handle at least some @value's
+% properly in indexes (we call \makevalueexpandable in \indexdummies).
+% The command has to be fully expandable (if the variable is set), since
+% the result winds up in the index file. This means that if the
+% variable's value contains other Texinfo commands, it's almost certain
+% it will fail (although perhaps we could fix that with sufficient work
+% to do a one-level expansion on the result, instead of complete).
+%
+\def\expandablevalue#1{%
+ \expandafter\ifx\csname SET#1\endcsname\relax
+ {[No value for ``#1'']}%
+ \message{Variable `#1', used in @value, is not set.}%
+ \else
+ \csname SET#1\endcsname
+ \fi
+}
+
+% @ifset VAR ... @end ifset reads the `...' iff VAR has been defined
+% with @set.
+%
+% To get special treatment of `@end ifset,' call \makeond and the redefine.
+%
+\makecond{ifset}
+\def\ifset{\parsearg{\doifset{\let\next=\ifsetfail}}}
+\def\doifset#1#2{%
+ {%
+ \makevalueexpandable
+ \let\next=\empty
+ \expandafter\ifx\csname SET#2\endcsname\relax
+ #1% If not set, redefine \next.
+ \fi
+ \expandafter
+ }\next
+}
+\def\ifsetfail{\doignore{ifset}}
+
+% @ifclear VAR ... @end ifclear reads the `...' iff VAR has never been
+% defined with @set, or has been undefined with @clear.
+%
+% The `\else' inside the `\doifset' parameter is a trick to reuse the
+% above code: if the variable is not set, do nothing, if it is set,
+% then redefine \next to \ifclearfail.
+%
+\makecond{ifclear}
+\def\ifclear{\parsearg{\doifset{\else \let\next=\ifclearfail}}}
+\def\ifclearfail{\doignore{ifclear}}
+
+% @dircategory CATEGORY -- specify a category of the dir file
+% which this file should belong to. Ignore this in TeX.
+\let\dircategory=\comment
+
+% @defininfoenclose.
+\let\definfoenclose=\comment
+
+
+\message{indexing,}
+% Index generation facilities
+
+% Define \newwrite to be identical to plain tex's \newwrite
+% except not \outer, so it can be used within macros and \if's.
+\edef\newwrite{\makecsname{ptexnewwrite}}
+
+% \newindex {foo} defines an index named foo.
+% It automatically defines \fooindex such that
+% \fooindex ...rest of line... puts an entry in the index foo.
+% It also defines \fooindfile to be the number of the output channel for
+% the file that accumulates this index. The file's extension is foo.
+% The name of an index should be no more than 2 characters long
+% for the sake of vms.
+%
+\def\newindex#1{%
+ \iflinks
+ \expandafter\newwrite \csname#1indfile\endcsname
+ \openout \csname#1indfile\endcsname \jobname.#1 % Open the file
+ \fi
+ \expandafter\xdef\csname#1index\endcsname{% % Define @#1index
+ \noexpand\doindex{#1}}
+}
+
+% @defindex foo == \newindex{foo}
+%
+\def\defindex{\parsearg\newindex}
+
+% Define @defcodeindex, like @defindex except put all entries in @code.
+%
+\def\defcodeindex{\parsearg\newcodeindex}
+%
+\def\newcodeindex#1{%
+ \iflinks
+ \expandafter\newwrite \csname#1indfile\endcsname
+ \openout \csname#1indfile\endcsname \jobname.#1
+ \fi
+ \expandafter\xdef\csname#1index\endcsname{%
+ \noexpand\docodeindex{#1}}%
+}
+
+
+% @synindex foo bar makes index foo feed into index bar.
+% Do this instead of @defindex foo if you don't want it as a separate index.
+%
+% @syncodeindex foo bar similar, but put all entries made for index foo
+% inside @code.
+%
+\def\synindex#1 #2 {\dosynindex\doindex{#1}{#2}}
+\def\syncodeindex#1 #2 {\dosynindex\docodeindex{#1}{#2}}
+
+% #1 is \doindex or \docodeindex, #2 the index getting redefined (foo),
+% #3 the target index (bar).
+\def\dosynindex#1#2#3{%
+ % Only do \closeout if we haven't already done it, else we'll end up
+ % closing the target index.
+ \expandafter \ifx\csname donesynindex#2\endcsname \undefined
+ % The \closeout helps reduce unnecessary open files; the limit on the
+ % Acorn RISC OS is a mere 16 files.
+ \expandafter\closeout\csname#2indfile\endcsname
+ \expandafter\let\csname\donesynindex#2\endcsname = 1
+ \fi
+ % redefine \fooindfile:
+ \expandafter\let\expandafter\temp\expandafter=\csname#3indfile\endcsname
+ \expandafter\let\csname#2indfile\endcsname=\temp
+ % redefine \fooindex:
+ \expandafter\xdef\csname#2index\endcsname{\noexpand#1{#3}}%
+}
+
+% Define \doindex, the driver for all \fooindex macros.
+% Argument #1 is generated by the calling \fooindex macro,
+% and it is "foo", the name of the index.
+
+% \doindex just uses \parsearg; it calls \doind for the actual work.
+% This is because \doind is more useful to call from other macros.
+
+% There is also \dosubind {index}{topic}{subtopic}
+% which makes an entry in a two-level index such as the operation index.
+
+\def\doindex#1{\edef\indexname{#1}\parsearg\singleindexer}
+\def\singleindexer #1{\doind{\indexname}{#1}}
+
+% like the previous two, but they put @code around the argument.
+\def\docodeindex#1{\edef\indexname{#1}\parsearg\singlecodeindexer}
+\def\singlecodeindexer #1{\doind{\indexname}{\code{#1}}}
+
+% Take care of Texinfo commands that can appear in an index entry.
+% Since there are some commands we want to expand, and others we don't,
+% we have to laboriously prevent expansion for those that we don't.
+%
+\def\indexdummies{%
+ \escapechar = `\\ % use backslash in output files.
+ \def\@{@}% change to @@ when we switch to @ as escape char in index files.
+ \def\ {\realbackslash\space }%
+ %
+ % Need these in case \tex is in effect and \{ is a \delimiter again.
+ % But can't use \lbracecmd and \rbracecmd because texindex assumes
+ % braces and backslashes are used only as delimiters.
+ \let\{ = \mylbrace
+ \let\} = \myrbrace
+ %
+ % I don't entirely understand this, but when an index entry is
+ % generated from a macro call, the \endinput which \scanmacro inserts
+ % causes processing to be prematurely terminated. This is,
+ % apparently, because \indexsorttmp is fully expanded, and \endinput
+ % is an expandable command. The redefinition below makes \endinput
+ % disappear altogether for that purpose -- although logging shows that
+ % processing continues to some further point. On the other hand, it
+ % seems \endinput does not hurt in the printed index arg, since that
+ % is still getting written without apparent harm.
+ %
+ % Sample source (mac-idx3.tex, reported by Graham Percival to
+ % help-texinfo, 22may06):
+ % @macro funindex {WORD}
+ % @findex xyz
+ % @end macro
+ % ...
+ % @funindex commtest
+ %
+ % The above is not enough to reproduce the bug, but it gives the flavor.
+ %
+ % Sample whatsit resulting:
+ % .@write3{\entry{xyz}{@folio }{@code {xyz@endinput }}}
+ %
+ % So:
+ \let\endinput = \empty
+ %
+ % Do the redefinitions.
+ \commondummies
+}
+
+% For the aux and toc files, @ is the escape character. So we want to
+% redefine everything using @ as the escape character (instead of
+% \realbackslash, still used for index files). When everything uses @,
+% this will be simpler.
+%
+\def\atdummies{%
+ \def\@{@@}%
+ \def\ {@ }%
+ \let\{ = \lbraceatcmd
+ \let\} = \rbraceatcmd
+ %
+ % Do the redefinitions.
+ \commondummies
+ \otherbackslash
+}
+
+% Called from \indexdummies and \atdummies.
+%
+\def\commondummies{%
+ %
+ % \definedummyword defines \#1 as \string\#1\space, thus effectively
+ % preventing its expansion. This is used only for control% words,
+ % not control letters, because the \space would be incorrect for
+ % control characters, but is needed to separate the control word
+ % from whatever follows.
+ %
+ % For control letters, we have \definedummyletter, which omits the
+ % space.
+ %
+ % These can be used both for control words that take an argument and
+ % those that do not. If it is followed by {arg} in the input, then
+ % that will dutifully get written to the index (or wherever).
+ %
+ \def\definedummyword ##1{\def##1{\string##1\space}}%
+ \def\definedummyletter##1{\def##1{\string##1}}%
+ \let\definedummyaccent\definedummyletter
+ %
+ \commondummiesnofonts
+ %
+ \definedummyletter\_%
+ %
+ % Non-English letters.
+ \definedummyword\AA
+ \definedummyword\AE
+ \definedummyword\L
+ \definedummyword\OE
+ \definedummyword\O
+ \definedummyword\aa
+ \definedummyword\ae
+ \definedummyword\l
+ \definedummyword\oe
+ \definedummyword\o
+ \definedummyword\ss
+ \definedummyword\exclamdown
+ \definedummyword\questiondown
+ \definedummyword\ordf
+ \definedummyword\ordm
+ %
+ % Although these internal commands shouldn't show up, sometimes they do.
+ \definedummyword\bf
+ \definedummyword\gtr
+ \definedummyword\hat
+ \definedummyword\less
+ \definedummyword\sf
+ \definedummyword\sl
+ \definedummyword\tclose
+ \definedummyword\tt
+ %
+ \definedummyword\LaTeX
+ \definedummyword\TeX
+ %
+ % Assorted special characters.
+ \definedummyword\bullet
+ \definedummyword\comma
+ \definedummyword\copyright
+ \definedummyword\registeredsymbol
+ \definedummyword\dots
+ \definedummyword\enddots
+ \definedummyword\equiv
+ \definedummyword\error
+ \definedummyword\euro
+ \definedummyword\guillemetleft
+ \definedummyword\guillemetright
+ \definedummyword\guilsinglleft
+ \definedummyword\guilsinglright
+ \definedummyword\expansion
+ \definedummyword\minus
+ \definedummyword\pounds
+ \definedummyword\point
+ \definedummyword\print
+ \definedummyword\quotedblbase
+ \definedummyword\quotedblleft
+ \definedummyword\quotedblright
+ \definedummyword\quoteleft
+ \definedummyword\quoteright
+ \definedummyword\quotesinglbase
+ \definedummyword\result
+ \definedummyword\textdegree
+ %
+ % We want to disable all macros so that they are not expanded by \write.
+ \macrolist
+ %
+ \normalturnoffactive
+ %
+ % Handle some cases of @value -- where it does not contain any
+ % (non-fully-expandable) commands.
+ \makevalueexpandable
+}
+
+% \commondummiesnofonts: common to \commondummies and \indexnofonts.
+%
+\def\commondummiesnofonts{%
+ % Control letters and accents.
+ \definedummyletter\!%
+ \definedummyaccent\"%
+ \definedummyaccent\'%
+ \definedummyletter\*%
+ \definedummyaccent\,%
+ \definedummyletter\.%
+ \definedummyletter\/%
+ \definedummyletter\:%
+ \definedummyaccent\=%
+ \definedummyletter\?%
+ \definedummyaccent\^%
+ \definedummyaccent\`%
+ \definedummyaccent\~%
+ \definedummyword\u
+ \definedummyword\v
+ \definedummyword\H
+ \definedummyword\dotaccent
+ \definedummyword\ringaccent
+ \definedummyword\tieaccent
+ \definedummyword\ubaraccent
+ \definedummyword\udotaccent
+ \definedummyword\dotless
+ %
+ % Texinfo font commands.
+ \definedummyword\b
+ \definedummyword\i
+ \definedummyword\r
+ \definedummyword\sc
+ \definedummyword\t
+ %
+ % Commands that take arguments.
+ \definedummyword\acronym
+ \definedummyword\cite
+ \definedummyword\code
+ \definedummyword\command
+ \definedummyword\dfn
+ \definedummyword\emph
+ \definedummyword\env
+ \definedummyword\file
+ \definedummyword\kbd
+ \definedummyword\key
+ \definedummyword\math
+ \definedummyword\option
+ \definedummyword\pxref
+ \definedummyword\ref
+ \definedummyword\samp
+ \definedummyword\strong
+ \definedummyword\tie
+ \definedummyword\uref
+ \definedummyword\url
+ \definedummyword\var
+ \definedummyword\verb
+ \definedummyword\w
+ \definedummyword\xref
+}
+
+% \indexnofonts is used when outputting the strings to sort the index
+% by, and when constructing control sequence names. It eliminates all
+% control sequences and just writes whatever the best ASCII sort string
+% would be for a given command (usually its argument).
+%
+\def\indexnofonts{%
+ % Accent commands should become @asis.
+ \def\definedummyaccent##1{\let##1\asis}%
+ % We can just ignore other control letters.
+ \def\definedummyletter##1{\let##1\empty}%
+ % Hopefully, all control words can become @asis.
+ \let\definedummyword\definedummyaccent
+ %
+ \commondummiesnofonts
+ %
+ % Don't no-op \tt, since it isn't a user-level command
+ % and is used in the definitions of the active chars like <, >, |, etc.
+ % Likewise with the other plain tex font commands.
+ %\let\tt=\asis
+ %
+ \def\ { }%
+ \def\@{@}%
+ % how to handle braces?
+ \def\_{\normalunderscore}%
+ %
+ % Non-English letters.
+ \def\AA{AA}%
+ \def\AE{AE}%
+ \def\L{L}%
+ \def\OE{OE}%
+ \def\O{O}%
+ \def\aa{aa}%
+ \def\ae{ae}%
+ \def\l{l}%
+ \def\oe{oe}%
+ \def\o{o}%
+ \def\ss{ss}%
+ \def\exclamdown{!}%
+ \def\questiondown{?}%
+ \def\ordf{a}%
+ \def\ordm{o}%
+ %
+ \def\LaTeX{LaTeX}%
+ \def\TeX{TeX}%
+ %
+ % Assorted special characters.
+ % (The following {} will end up in the sort string, but that's ok.)
+ \def\bullet{bullet}%
+ \def\comma{,}%
+ \def\copyright{copyright}%
+ \def\registeredsymbol{R}%
+ \def\dots{...}%
+ \def\enddots{...}%
+ \def\equiv{==}%
+ \def\error{error}%
+ \def\euro{euro}%
+ \def\guillemetleft{<<}%
+ \def\guillemetright{>>}%
+ \def\guilsinglleft{<}%
+ \def\guilsinglright{>}%
+ \def\expansion{==>}%
+ \def\minus{-}%
+ \def\pounds{pounds}%
+ \def\point{.}%
+ \def\print{-|}%
+ \def\quotedblbase{"}%
+ \def\quotedblleft{"}%
+ \def\quotedblright{"}%
+ \def\quoteleft{`}%
+ \def\quoteright{'}%
+ \def\quotesinglbase{,}%
+ \def\result{=>}%
+ \def\textdegree{degrees}%
+ %
+ % We need to get rid of all macros, leaving only the arguments (if present).
+ % Of course this is not nearly correct, but it is the best we can do for now.
+ % makeinfo does not expand macros in the argument to @deffn, which ends up
+ % writing an index entry, and texindex isn't prepared for an index sort entry
+ % that starts with \.
+ %
+ % Since macro invocations are followed by braces, we can just redefine them
+ % to take a single TeX argument. The case of a macro invocation that
+ % goes to end-of-line is not handled.
+ %
+ \macrolist
+}
+
+\let\indexbackslash=0 %overridden during \printindex.
+\let\SETmarginindex=\relax % put index entries in margin (undocumented)?
+
+% Most index entries go through here, but \dosubind is the general case.
+% #1 is the index name, #2 is the entry text.
+\def\doind#1#2{\dosubind{#1}{#2}{}}
+
+% Workhorse for all \fooindexes.
+% #1 is name of index, #2 is stuff to put there, #3 is subentry --
+% empty if called from \doind, as we usually are (the main exception
+% is with most defuns, which call us directly).
+%
+\def\dosubind#1#2#3{%
+ \iflinks
+ {%
+ % Store the main index entry text (including the third arg).
+ \toks0 = {#2}%
+ % If third arg is present, precede it with a space.
+ \def\thirdarg{#3}%
+ \ifx\thirdarg\empty \else
+ \toks0 = \expandafter{\the\toks0 \space #3}%
+ \fi
+ %
+ \edef\writeto{\csname#1indfile\endcsname}%
+ %
+ \safewhatsit\dosubindwrite
+ }%
+ \fi
+}
+
+% Write the entry in \toks0 to the index file:
+%
+\def\dosubindwrite{%
+ % Put the index entry in the margin if desired.
+ \ifx\SETmarginindex\relax\else
+ \insert\margin{\hbox{\vrule height8pt depth3pt width0pt \the\toks0}}%
+ \fi
+ %
+ % Remember, we are within a group.
+ \indexdummies % Must do this here, since \bf, etc expand at this stage
+ \def\backslashcurfont{\indexbackslash}% \indexbackslash isn't defined now
+ % so it will be output as is; and it will print as backslash.
+ %
+ % Process the index entry with all font commands turned off, to
+ % get the string to sort by.
+ {\indexnofonts
+ \edef\temp{\the\toks0}% need full expansion
+ \xdef\indexsorttmp{\temp}%
+ }%
+ %
+ % Set up the complete index entry, with both the sort key and
+ % the original text, including any font commands. We write
+ % three arguments to \entry to the .?? file (four in the
+ % subentry case), texindex reduces to two when writing the .??s
+ % sorted result.
+ \edef\temp{%
+ \write\writeto{%
+ \string\entry{\indexsorttmp}{\noexpand\folio}{\the\toks0}}%
+ }%
+ \temp
+}
+
+% Take care of unwanted page breaks/skips around a whatsit:
+%
+% If a skip is the last thing on the list now, preserve it
+% by backing up by \lastskip, doing the \write, then inserting
+% the skip again. Otherwise, the whatsit generated by the
+% \write or \pdfdest will make \lastskip zero. The result is that
+% sequences like this:
+% @end defun
+% @tindex whatever
+% @defun ...
+% will have extra space inserted, because the \medbreak in the
+% start of the @defun won't see the skip inserted by the @end of
+% the previous defun.
+%
+% But don't do any of this if we're not in vertical mode. We
+% don't want to do a \vskip and prematurely end a paragraph.
+%
+% Avoid page breaks due to these extra skips, too.
+%
+% But wait, there is a catch there:
+% We'll have to check whether \lastskip is zero skip. \ifdim is not
+% sufficient for this purpose, as it ignores stretch and shrink parts
+% of the skip. The only way seems to be to check the textual
+% representation of the skip.
+%
+% The following is almost like \def\zeroskipmacro{0.0pt} except that
+% the ``p'' and ``t'' characters have catcode \other, not 11 (letter).
+%
+\edef\zeroskipmacro{\expandafter\the\csname z@skip\endcsname}
+%
+\newskip\whatsitskip
+\newcount\whatsitpenalty
+%
+% ..., ready, GO:
+%
+\def\safewhatsit#1{%
+\ifhmode
+ #1%
+\else
+ % \lastskip and \lastpenalty cannot both be nonzero simultaneously.
+ \whatsitskip = \lastskip
+ \edef\lastskipmacro{\the\lastskip}%
+ \whatsitpenalty = \lastpenalty
+ %
+ % If \lastskip is nonzero, that means the last item was a
+ % skip. And since a skip is discardable, that means this
+ % -\whatsitskip glue we're inserting is preceded by a
+ % non-discardable item, therefore it is not a potential
+ % breakpoint, therefore no \nobreak needed.
+ \ifx\lastskipmacro\zeroskipmacro
+ \else
+ \vskip-\whatsitskip
+ \fi
+ %
+ #1%
+ %
+ \ifx\lastskipmacro\zeroskipmacro
+ % If \lastskip was zero, perhaps the last item was a penalty, and
+ % perhaps it was >=10000, e.g., a \nobreak. In that case, we want
+ % to re-insert the same penalty (values >10000 are used for various
+ % signals); since we just inserted a non-discardable item, any
+ % following glue (such as a \parskip) would be a breakpoint. For example:
+ %
+ % @deffn deffn-whatever
+ % @vindex index-whatever
+ % Description.
+ % would allow a break between the index-whatever whatsit
+ % and the "Description." paragraph.
+ \ifnum\whatsitpenalty>9999 \penalty\whatsitpenalty \fi
+ \else
+ % On the other hand, if we had a nonzero \lastskip,
+ % this make-up glue would be preceded by a non-discardable item
+ % (the whatsit from the \write), so we must insert a \nobreak.
+ \nobreak\vskip\whatsitskip
+ \fi
+\fi
+}
+
+% The index entry written in the file actually looks like
+% \entry {sortstring}{page}{topic}
+% or
+% \entry {sortstring}{page}{topic}{subtopic}
+% The texindex program reads in these files and writes files
+% containing these kinds of lines:
+% \initial {c}
+% before the first topic whose initial is c
+% \entry {topic}{pagelist}
+% for a topic that is used without subtopics
+% \primary {topic}
+% for the beginning of a topic that is used with subtopics
+% \secondary {subtopic}{pagelist}
+% for each subtopic.
+
+% Define the user-accessible indexing commands
+% @findex, @vindex, @kindex, @cindex.
+
+\def\findex {\fnindex}
+\def\kindex {\kyindex}
+\def\cindex {\cpindex}
+\def\vindex {\vrindex}
+\def\tindex {\tpindex}
+\def\pindex {\pgindex}
+
+\def\cindexsub {\begingroup\obeylines\cindexsub}
+{\obeylines %
+\gdef\cindexsub "#1" #2^^M{\endgroup %
+\dosubind{cp}{#2}{#1}}}
+
+% Define the macros used in formatting output of the sorted index material.
+
+% @printindex causes a particular index (the ??s file) to get printed.
+% It does not print any chapter heading (usually an @unnumbered).
+%
+\parseargdef\printindex{\begingroup
+ \dobreak \chapheadingskip{10000}%
+ %
+ \smallfonts \rm
+ \tolerance = 9500
+ \plainfrenchspacing
+ \everypar = {}% don't want the \kern\-parindent from indentation suppression.
+ %
+ % See if the index file exists and is nonempty.
+ % Change catcode of @ here so that if the index file contains
+ % \initial {@}
+ % as its first line, TeX doesn't complain about mismatched braces
+ % (because it thinks @} is a control sequence).
+ \catcode`\@ = 11
+ \openin 1 \jobname.#1s
+ \ifeof 1
+ % \enddoublecolumns gets confused if there is no text in the index,
+ % and it loses the chapter title and the aux file entries for the
+ % index. The easiest way to prevent this problem is to make sure
+ % there is some text.
+ \putwordIndexNonexistent
+ \else
+ %
+ % If the index file exists but is empty, then \openin leaves \ifeof
+ % false. We have to make TeX try to read something from the file, so
+ % it can discover if there is anything in it.
+ \read 1 to \temp
+ \ifeof 1
+ \putwordIndexIsEmpty
+ \else
+ % Index files are almost Texinfo source, but we use \ as the escape
+ % character. It would be better to use @, but that's too big a change
+ % to make right now.
+ \def\indexbackslash{\backslashcurfont}%
+ \catcode`\\ = 0
+ \escapechar = `\\
+ \begindoublecolumns
+ \input \jobname.#1s
+ \enddoublecolumns
+ \fi
+ \fi
+ \closein 1
+\endgroup}
+
+% These macros are used by the sorted index file itself.
+% Change them to control the appearance of the index.
+
+\def\initial#1{{%
+ % Some minor font changes for the special characters.
+ \let\tentt=\sectt \let\tt=\sectt \let\sf=\sectt
+ %
+ % Remove any glue we may have, we'll be inserting our own.
+ \removelastskip
+ %
+ % We like breaks before the index initials, so insert a bonus.
+ \nobreak
+ \vskip 0pt plus 3\baselineskip
+ \penalty 0
+ \vskip 0pt plus -3\baselineskip
+ %
+ % Typeset the initial. Making this add up to a whole number of
+ % baselineskips increases the chance of the dots lining up from column
+ % to column. It still won't often be perfect, because of the stretch
+ % we need before each entry, but it's better.
+ %
+ % No shrink because it confuses \balancecolumns.
+ \vskip 1.67\baselineskip plus .5\baselineskip
+ \leftline{\secbf #1}%
+ % Do our best not to break after the initial.
+ \nobreak
+ \vskip .33\baselineskip plus .1\baselineskip
+}}
+
+% \entry typesets a paragraph consisting of the text (#1), dot leaders, and
+% then page number (#2) flushed to the right margin. It is used for index
+% and table of contents entries. The paragraph is indented by \leftskip.
+%
+% A straightforward implementation would start like this:
+% \def\entry#1#2{...
+% But this frozes the catcodes in the argument, and can cause problems to
+% @code, which sets - active. This problem was fixed by a kludge---
+% ``-'' was active throughout whole index, but this isn't really right.
+%
+% The right solution is to prevent \entry from swallowing the whole text.
+% --kasal, 21nov03
+\def\entry{%
+ \begingroup
+ %
+ % Start a new paragraph if necessary, so our assignments below can't
+ % affect previous text.
+ \par
+ %
+ % Do not fill out the last line with white space.
+ \parfillskip = 0in
+ %
+ % No extra space above this paragraph.
+ \parskip = 0in
+ %
+ % Do not prefer a separate line ending with a hyphen to fewer lines.
+ \finalhyphendemerits = 0
+ %
+ % \hangindent is only relevant when the entry text and page number
+ % don't both fit on one line. In that case, bob suggests starting the
+ % dots pretty far over on the line. Unfortunately, a large
+ % indentation looks wrong when the entry text itself is broken across
+ % lines. So we use a small indentation and put up with long leaders.
+ %
+ % \hangafter is reset to 1 (which is the value we want) at the start
+ % of each paragraph, so we need not do anything with that.
+ \hangindent = 2em
+ %
+ % When the entry text needs to be broken, just fill out the first line
+ % with blank space.
+ \rightskip = 0pt plus1fil
+ %
+ % A bit of stretch before each entry for the benefit of balancing
+ % columns.
+ \vskip 0pt plus1pt
+ %
+ % Swallow the left brace of the text (first parameter):
+ \afterassignment\doentry
+ \let\temp =
+}
+\def\doentry{%
+ \bgroup % Instead of the swallowed brace.
+ \noindent
+ \aftergroup\finishentry
+ % And now comes the text of the entry.
+}
+\def\finishentry#1{%
+ % #1 is the page number.
+ %
+ % The following is kludged to not output a line of dots in the index if
+ % there are no page numbers. The next person who breaks this will be
+ % cursed by a Unix daemon.
+ \setbox\boxA = \hbox{#1}%
+ \ifdim\wd\boxA = 0pt
+ \ %
+ \else
+ %
+ % If we must, put the page number on a line of its own, and fill out
+ % this line with blank space. (The \hfil is overwhelmed with the
+ % fill leaders glue in \indexdotfill if the page number does fit.)
+ \hfil\penalty50
+ \null\nobreak\indexdotfill % Have leaders before the page number.
+ %
+ % The `\ ' here is removed by the implicit \unskip that TeX does as
+ % part of (the primitive) \par. Without it, a spurious underfull
+ % \hbox ensues.
+ \ifpdf
+ \pdfgettoks#1.%
+ \ \the\toksA
+ \else
+ \ #1%
+ \fi
+ \fi
+ \par
+ \endgroup
+}
+
+% Like plain.tex's \dotfill, except uses up at least 1 em.
+\def\indexdotfill{\cleaders
+ \hbox{$\mathsurround=0pt \mkern1.5mu.\mkern1.5mu$}\hskip 1em plus 1fill}
+
+\def\primary #1{\line{#1\hfil}}
+
+\newskip\secondaryindent \secondaryindent=0.5cm
+\def\secondary#1#2{{%
+ \parfillskip=0in
+ \parskip=0in
+ \hangindent=1in
+ \hangafter=1
+ \noindent\hskip\secondaryindent\hbox{#1}\indexdotfill
+ \ifpdf
+ \pdfgettoks#2.\ \the\toksA % The page number ends the paragraph.
+ \else
+ #2
+ \fi
+ \par
+}}
+
+% Define two-column mode, which we use to typeset indexes.
+% Adapted from the TeXbook, page 416, which is to say,
+% the manmac.tex format used to print the TeXbook itself.
+\catcode`\@=11
+
+\newbox\partialpage
+\newdimen\doublecolumnhsize
+
+\def\begindoublecolumns{\begingroup % ended by \enddoublecolumns
+ % Grab any single-column material above us.
+ \output = {%
+ %
+ % Here is a possibility not foreseen in manmac: if we accumulate a
+ % whole lot of material, we might end up calling this \output
+ % routine twice in a row (see the doublecol-lose test, which is
+ % essentially a couple of indexes with @setchapternewpage off). In
+ % that case we just ship out what is in \partialpage with the normal
+ % output routine. Generally, \partialpage will be empty when this
+ % runs and this will be a no-op. See the indexspread.tex test case.
+ \ifvoid\partialpage \else
+ \onepageout{\pagecontents\partialpage}%
+ \fi
+ %
+ \global\setbox\partialpage = \vbox{%
+ % Unvbox the main output page.
+ \unvbox\PAGE
+ \kern-\topskip \kern\baselineskip
+ }%
+ }%
+ \eject % run that output routine to set \partialpage
+ %
+ % Use the double-column output routine for subsequent pages.
+ \output = {\doublecolumnout}%
+ %
+ % Change the page size parameters. We could do this once outside this
+ % routine, in each of @smallbook, @afourpaper, and the default 8.5x11
+ % format, but then we repeat the same computation. Repeating a couple
+ % of assignments once per index is clearly meaningless for the
+ % execution time, so we may as well do it in one place.
+ %
+ % First we halve the line length, less a little for the gutter between
+ % the columns. We compute the gutter based on the line length, so it
+ % changes automatically with the paper format. The magic constant
+ % below is chosen so that the gutter has the same value (well, +-<1pt)
+ % as it did when we hard-coded it.
+ %
+ % We put the result in a separate register, \doublecolumhsize, so we
+ % can restore it in \pagesofar, after \hsize itself has (potentially)
+ % been clobbered.
+ %
+ \doublecolumnhsize = \hsize
+ \advance\doublecolumnhsize by -.04154\hsize
+ \divide\doublecolumnhsize by 2
+ \hsize = \doublecolumnhsize
+ %
+ % Double the \vsize as well. (We don't need a separate register here,
+ % since nobody clobbers \vsize.)
+ \vsize = 2\vsize
+}
+
+% The double-column output routine for all double-column pages except
+% the last.
+%
+\def\doublecolumnout{%
+ \splittopskip=\topskip \splitmaxdepth=\maxdepth
+ % Get the available space for the double columns -- the normal
+ % (undoubled) page height minus any material left over from the
+ % previous page.
+ \dimen@ = \vsize
+ \divide\dimen@ by 2
+ \advance\dimen@ by -\ht\partialpage
+ %
+ % box0 will be the left-hand column, box2 the right.
+ \setbox0=\vsplit255 to\dimen@ \setbox2=\vsplit255 to\dimen@
+ \onepageout\pagesofar
+ \unvbox255
+ \penalty\outputpenalty
+}
+%
+% Re-output the contents of the output page -- any previous material,
+% followed by the two boxes we just split, in box0 and box2.
+\def\pagesofar{%
+ \unvbox\partialpage
+ %
+ \hsize = \doublecolumnhsize
+ \wd0=\hsize \wd2=\hsize
+ \hbox to\pagewidth{\box0\hfil\box2}%
+}
+%
+% All done with double columns.
+\def\enddoublecolumns{%
+ % The following penalty ensures that the page builder is exercised
+ % _before_ we change the output routine. This is necessary in the
+ % following situation:
+ %
+ % The last section of the index consists only of a single entry.
+ % Before this section, \pagetotal is less than \pagegoal, so no
+ % break occurs before the last section starts. However, the last
+ % section, consisting of \initial and the single \entry, does not
+ % fit on the page and has to be broken off. Without the following
+ % penalty the page builder will not be exercised until \eject
+ % below, and by that time we'll already have changed the output
+ % routine to the \balancecolumns version, so the next-to-last
+ % double-column page will be processed with \balancecolumns, which
+ % is wrong: The two columns will go to the main vertical list, with
+ % the broken-off section in the recent contributions. As soon as
+ % the output routine finishes, TeX starts reconsidering the page
+ % break. The two columns and the broken-off section both fit on the
+ % page, because the two columns now take up only half of the page
+ % goal. When TeX sees \eject from below which follows the final
+ % section, it invokes the new output routine that we've set after
+ % \balancecolumns below; \onepageout will try to fit the two columns
+ % and the final section into the vbox of \pageheight (see
+ % \pagebody), causing an overfull box.
+ %
+ % Note that glue won't work here, because glue does not exercise the
+ % page builder, unlike penalties (see The TeXbook, pp. 280-281).
+ \penalty0
+ %
+ \output = {%
+ % Split the last of the double-column material. Leave it on the
+ % current page, no automatic page break.
+ \balancecolumns
+ %
+ % If we end up splitting too much material for the current page,
+ % though, there will be another page break right after this \output
+ % invocation ends. Having called \balancecolumns once, we do not
+ % want to call it again. Therefore, reset \output to its normal
+ % definition right away. (We hope \balancecolumns will never be
+ % called on to balance too much material, but if it is, this makes
+ % the output somewhat more palatable.)
+ \global\output = {\onepageout{\pagecontents\PAGE}}%
+ }%
+ \eject
+ \endgroup % started in \begindoublecolumns
+ %
+ % \pagegoal was set to the doubled \vsize above, since we restarted
+ % the current page. We're now back to normal single-column
+ % typesetting, so reset \pagegoal to the normal \vsize (after the
+ % \endgroup where \vsize got restored).
+ \pagegoal = \vsize
+}
+%
+% Called at the end of the double column material.
+\def\balancecolumns{%
+ \setbox0 = \vbox{\unvbox255}% like \box255 but more efficient, see p.120.
+ \dimen@ = \ht0
+ \advance\dimen@ by \topskip
+ \advance\dimen@ by-\baselineskip
+ \divide\dimen@ by 2 % target to split to
+ %debug\message{final 2-column material height=\the\ht0, target=\the\dimen@.}%
+ \splittopskip = \topskip
+ % Loop until we get a decent breakpoint.
+ {%
+ \vbadness = 10000
+ \loop
+ \global\setbox3 = \copy0
+ \global\setbox1 = \vsplit3 to \dimen@
+ \ifdim\ht3>\dimen@
+ \global\advance\dimen@ by 1pt
+ \repeat
+ }%
+ %debug\message{split to \the\dimen@, column heights: \the\ht1, \the\ht3.}%
+ \setbox0=\vbox to\dimen@{\unvbox1}%
+ \setbox2=\vbox to\dimen@{\unvbox3}%
+ %
+ \pagesofar
+}
+\catcode`\@ = \other
+
+
+\message{sectioning,}
+% Chapters, sections, etc.
+
+% \unnumberedno is an oxymoron, of course. But we count the unnumbered
+% sections so that we can refer to them unambiguously in the pdf
+% outlines by their "section number". We avoid collisions with chapter
+% numbers by starting them at 10000. (If a document ever has 10000
+% chapters, we're in trouble anyway, I'm sure.)
+\newcount\unnumberedno \unnumberedno = 10000
+\newcount\chapno
+\newcount\secno \secno=0
+\newcount\subsecno \subsecno=0
+\newcount\subsubsecno \subsubsecno=0
+
+% This counter is funny since it counts through charcodes of letters A, B, ...
+\newcount\appendixno \appendixno = `\@
+%
+% \def\appendixletter{\char\the\appendixno}
+% We do the following ugly conditional instead of the above simple
+% construct for the sake of pdftex, which needs the actual
+% letter in the expansion, not just typeset.
+%
+\def\appendixletter{%
+ \ifnum\appendixno=`A A%
+ \else\ifnum\appendixno=`B B%
+ \else\ifnum\appendixno=`C C%
+ \else\ifnum\appendixno=`D D%
+ \else\ifnum\appendixno=`E E%
+ \else\ifnum\appendixno=`F F%
+ \else\ifnum\appendixno=`G G%
+ \else\ifnum\appendixno=`H H%
+ \else\ifnum\appendixno=`I I%
+ \else\ifnum\appendixno=`J J%
+ \else\ifnum\appendixno=`K K%
+ \else\ifnum\appendixno=`L L%
+ \else\ifnum\appendixno=`M M%
+ \else\ifnum\appendixno=`N N%
+ \else\ifnum\appendixno=`O O%
+ \else\ifnum\appendixno=`P P%
+ \else\ifnum\appendixno=`Q Q%
+ \else\ifnum\appendixno=`R R%
+ \else\ifnum\appendixno=`S S%
+ \else\ifnum\appendixno=`T T%
+ \else\ifnum\appendixno=`U U%
+ \else\ifnum\appendixno=`V V%
+ \else\ifnum\appendixno=`W W%
+ \else\ifnum\appendixno=`X X%
+ \else\ifnum\appendixno=`Y Y%
+ \else\ifnum\appendixno=`Z Z%
+ % The \the is necessary, despite appearances, because \appendixletter is
+ % expanded while writing the .toc file. \char\appendixno is not
+ % expandable, thus it is written literally, thus all appendixes come out
+ % with the same letter (or @) in the toc without it.
+ \else\char\the\appendixno
+ \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi
+ \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi}
+
+% Each @chapter defines these (using marks) as the number+name, number
+% and name of the chapter. Page headings and footings can use
+% these. @section does likewise.
+\def\thischapter{}
+\def\thischapternum{}
+\def\thischaptername{}
+\def\thissection{}
+\def\thissectionnum{}
+\def\thissectionname{}
+
+\newcount\absseclevel % used to calculate proper heading level
+\newcount\secbase\secbase=0 % @raisesections/@lowersections modify this count
+
+% @raisesections: treat @section as chapter, @subsection as section, etc.
+\def\raisesections{\global\advance\secbase by -1}
+\let\up=\raisesections % original BFox name
+
+% @lowersections: treat @chapter as section, @section as subsection, etc.
+\def\lowersections{\global\advance\secbase by 1}
+\let\down=\lowersections % original BFox name
+
+% we only have subsub.
+\chardef\maxseclevel = 3
+%
+% A numbered section within an unnumbered changes to unnumbered too.
+% To achive this, remember the "biggest" unnum. sec. we are currently in:
+\chardef\unmlevel = \maxseclevel
+%
+% Trace whether the current chapter is an appendix or not:
+% \chapheadtype is "N" or "A", unnumbered chapters are ignored.
+\def\chapheadtype{N}
+
+% Choose a heading macro
+% #1 is heading type
+% #2 is heading level
+% #3 is text for heading
+\def\genhead#1#2#3{%
+ % Compute the abs. sec. level:
+ \absseclevel=#2
+ \advance\absseclevel by \secbase
+ % Make sure \absseclevel doesn't fall outside the range:
+ \ifnum \absseclevel < 0
+ \absseclevel = 0
+ \else
+ \ifnum \absseclevel > 3
+ \absseclevel = 3
+ \fi
+ \fi
+ % The heading type:
+ \def\headtype{#1}%
+ \if \headtype U%
+ \ifnum \absseclevel < \unmlevel
+ \chardef\unmlevel = \absseclevel
+ \fi
+ \else
+ % Check for appendix sections:
+ \ifnum \absseclevel = 0
+ \edef\chapheadtype{\headtype}%
+ \else
+ \if \headtype A\if \chapheadtype N%
+ \errmessage{@appendix... within a non-appendix chapter}%
+ \fi\fi
+ \fi
+ % Check for numbered within unnumbered:
+ \ifnum \absseclevel > \unmlevel
+ \def\headtype{U}%
+ \else
+ \chardef\unmlevel = 3
+ \fi
+ \fi
+ % Now print the heading:
+ \if \headtype U%
+ \ifcase\absseclevel
+ \unnumberedzzz{#3}%
+ \or \unnumberedseczzz{#3}%
+ \or \unnumberedsubseczzz{#3}%
+ \or \unnumberedsubsubseczzz{#3}%
+ \fi
+ \else
+ \if \headtype A%
+ \ifcase\absseclevel
+ \appendixzzz{#3}%
+ \or \appendixsectionzzz{#3}%
+ \or \appendixsubseczzz{#3}%
+ \or \appendixsubsubseczzz{#3}%
+ \fi
+ \else
+ \ifcase\absseclevel
+ \chapterzzz{#3}%
+ \or \seczzz{#3}%
+ \or \numberedsubseczzz{#3}%
+ \or \numberedsubsubseczzz{#3}%
+ \fi
+ \fi
+ \fi
+ \suppressfirstparagraphindent
+}
+
+% an interface:
+\def\numhead{\genhead N}
+\def\apphead{\genhead A}
+\def\unnmhead{\genhead U}
+
+% @chapter, @appendix, @unnumbered. Increment top-level counter, reset
+% all lower-level sectioning counters to zero.
+%
+% Also set \chaplevelprefix, which we prepend to @float sequence numbers
+% (e.g., figures), q.v. By default (before any chapter), that is empty.
+\let\chaplevelprefix = \empty
+%
+\outer\parseargdef\chapter{\numhead0{#1}} % normally numhead0 calls chapterzzz
+\def\chapterzzz#1{%
+ % section resetting is \global in case the chapter is in a group, such
+ % as an @include file.
+ \global\secno=0 \global\subsecno=0 \global\subsubsecno=0
+ \global\advance\chapno by 1
+ %
+ % Used for \float.
+ \gdef\chaplevelprefix{\the\chapno.}%
+ \resetallfloatnos
+ %
+ \message{\putwordChapter\space \the\chapno}%
+ %
+ % Write the actual heading.
+ \chapmacro{#1}{Ynumbered}{\the\chapno}%
+ %
+ % So @section and the like are numbered underneath this chapter.
+ \global\let\section = \numberedsec
+ \global\let\subsection = \numberedsubsec
+ \global\let\subsubsection = \numberedsubsubsec
+}
+
+\outer\parseargdef\appendix{\apphead0{#1}} % normally apphead0 calls appendixzzz
+\def\appendixzzz#1{%
+ \global\secno=0 \global\subsecno=0 \global\subsubsecno=0
+ \global\advance\appendixno by 1
+ \gdef\chaplevelprefix{\appendixletter.}%
+ \resetallfloatnos
+ %
+ \def\appendixnum{\putwordAppendix\space \appendixletter}%
+ \message{\appendixnum}%
+ %
+ \chapmacro{#1}{Yappendix}{\appendixletter}%
+ %
+ \global\let\section = \appendixsec
+ \global\let\subsection = \appendixsubsec
+ \global\let\subsubsection = \appendixsubsubsec
+}
+
+\outer\parseargdef\unnumbered{\unnmhead0{#1}} % normally unnmhead0 calls unnumberedzzz
+\def\unnumberedzzz#1{%
+ \global\secno=0 \global\subsecno=0 \global\subsubsecno=0
+ \global\advance\unnumberedno by 1
+ %
+ % Since an unnumbered has no number, no prefix for figures.
+ \global\let\chaplevelprefix = \empty
+ \resetallfloatnos
+ %
+ % This used to be simply \message{#1}, but TeX fully expands the
+ % argument to \message. Therefore, if #1 contained @-commands, TeX
+ % expanded them. For example, in `@unnumbered The @cite{Book}', TeX
+ % expanded @cite (which turns out to cause errors because \cite is meant
+ % to be executed, not expanded).
+ %
+ % Anyway, we don't want the fully-expanded definition of @cite to appear
+ % as a result of the \message, we just want `@cite' itself. We use
+ % \the<toks register> to achieve this: TeX expands \the<toks> only once,
+ % simply yielding the contents of <toks register>. (We also do this for
+ % the toc entries.)
+ \toks0 = {#1}%
+ \message{(\the\toks0)}%
+ %
+ \chapmacro{#1}{Ynothing}{\the\unnumberedno}%
+ %
+ \global\let\section = \unnumberedsec
+ \global\let\subsection = \unnumberedsubsec
+ \global\let\subsubsection = \unnumberedsubsubsec
+}
+
+% @centerchap is like @unnumbered, but the heading is centered.
+\outer\parseargdef\centerchap{%
+ % Well, we could do the following in a group, but that would break
+ % an assumption that \chapmacro is called at the outermost level.
+ % Thus we are safer this way: --kasal, 24feb04
+ \let\centerparametersmaybe = \centerparameters
+ \unnmhead0{#1}%
+ \let\centerparametersmaybe = \relax
+}
+
+% @top is like @unnumbered.
+\let\top\unnumbered
+
+% Sections.
+\outer\parseargdef\numberedsec{\numhead1{#1}} % normally calls seczzz
+\def\seczzz#1{%
+ \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1
+ \sectionheading{#1}{sec}{Ynumbered}{\the\chapno.\the\secno}%
+}
+
+\outer\parseargdef\appendixsection{\apphead1{#1}} % normally calls appendixsectionzzz
+\def\appendixsectionzzz#1{%
+ \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1
+ \sectionheading{#1}{sec}{Yappendix}{\appendixletter.\the\secno}%
+}
+\let\appendixsec\appendixsection
+
+\outer\parseargdef\unnumberedsec{\unnmhead1{#1}} % normally calls unnumberedseczzz
+\def\unnumberedseczzz#1{%
+ \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1
+ \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno.\the\secno}%
+}
+
+% Subsections.
+\outer\parseargdef\numberedsubsec{\numhead2{#1}} % normally calls numberedsubseczzz
+\def\numberedsubseczzz#1{%
+ \global\subsubsecno=0 \global\advance\subsecno by 1
+ \sectionheading{#1}{subsec}{Ynumbered}{\the\chapno.\the\secno.\the\subsecno}%
+}
+
+\outer\parseargdef\appendixsubsec{\apphead2{#1}} % normally calls appendixsubseczzz
+\def\appendixsubseczzz#1{%
+ \global\subsubsecno=0 \global\advance\subsecno by 1
+ \sectionheading{#1}{subsec}{Yappendix}%
+ {\appendixletter.\the\secno.\the\subsecno}%
+}
+
+\outer\parseargdef\unnumberedsubsec{\unnmhead2{#1}} %normally calls unnumberedsubseczzz
+\def\unnumberedsubseczzz#1{%
+ \global\subsubsecno=0 \global\advance\subsecno by 1
+ \sectionheading{#1}{subsec}{Ynothing}%
+ {\the\unnumberedno.\the\secno.\the\subsecno}%
+}
+
+% Subsubsections.
+\outer\parseargdef\numberedsubsubsec{\numhead3{#1}} % normally numberedsubsubseczzz
+\def\numberedsubsubseczzz#1{%
+ \global\advance\subsubsecno by 1
+ \sectionheading{#1}{subsubsec}{Ynumbered}%
+ {\the\chapno.\the\secno.\the\subsecno.\the\subsubsecno}%
+}
+
+\outer\parseargdef\appendixsubsubsec{\apphead3{#1}} % normally appendixsubsubseczzz
+\def\appendixsubsubseczzz#1{%
+ \global\advance\subsubsecno by 1
+ \sectionheading{#1}{subsubsec}{Yappendix}%
+ {\appendixletter.\the\secno.\the\subsecno.\the\subsubsecno}%
+}
+
+\outer\parseargdef\unnumberedsubsubsec{\unnmhead3{#1}} %normally unnumberedsubsubseczzz
+\def\unnumberedsubsubseczzz#1{%
+ \global\advance\subsubsecno by 1
+ \sectionheading{#1}{subsubsec}{Ynothing}%
+ {\the\unnumberedno.\the\secno.\the\subsecno.\the\subsubsecno}%
+}
+
+% These macros control what the section commands do, according
+% to what kind of chapter we are in (ordinary, appendix, or unnumbered).
+% Define them by default for a numbered chapter.
+\let\section = \numberedsec
+\let\subsection = \numberedsubsec
+\let\subsubsection = \numberedsubsubsec
+
+% Define @majorheading, @heading and @subheading
+
+% NOTE on use of \vbox for chapter headings, section headings, and such:
+% 1) We use \vbox rather than the earlier \line to permit
+% overlong headings to fold.
+% 2) \hyphenpenalty is set to 10000 because hyphenation in a
+% heading is obnoxious; this forbids it.
+% 3) Likewise, headings look best if no \parindent is used, and
+% if justification is not attempted. Hence \raggedright.
+
+
+\def\majorheading{%
+ {\advance\chapheadingskip by 10pt \chapbreak }%
+ \parsearg\chapheadingzzz
+}
+
+\def\chapheading{\chapbreak \parsearg\chapheadingzzz}
+\def\chapheadingzzz#1{%
+ {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
+ \parindent=0pt\raggedright
+ \rm #1\hfill}}%
+ \bigskip \par\penalty 200\relax
+ \suppressfirstparagraphindent
+}
+
+% @heading, @subheading, @subsubheading.
+\parseargdef\heading{\sectionheading{#1}{sec}{Yomitfromtoc}{}
+ \suppressfirstparagraphindent}
+\parseargdef\subheading{\sectionheading{#1}{subsec}{Yomitfromtoc}{}
+ \suppressfirstparagraphindent}
+\parseargdef\subsubheading{\sectionheading{#1}{subsubsec}{Yomitfromtoc}{}
+ \suppressfirstparagraphindent}
+
+% These macros generate a chapter, section, etc. heading only
+% (including whitespace, linebreaking, etc. around it),
+% given all the information in convenient, parsed form.
+
+%%% Args are the skip and penalty (usually negative)
+\def\dobreak#1#2{\par\ifdim\lastskip<#1\removelastskip\penalty#2\vskip#1\fi}
+
+%%% Define plain chapter starts, and page on/off switching for it
+% Parameter controlling skip before chapter headings (if needed)
+
+\newskip\chapheadingskip
+
+\def\chapbreak{\dobreak \chapheadingskip {-4000}}
+\def\chappager{\par\vfill\supereject}
+% Because \domark is called before \chapoddpage, the filler page will
+% get the headings for the next chapter, which is wrong. But we don't
+% care -- we just disable all headings on the filler page.
+\def\chapoddpage{%
+ \chappager
+ \ifodd\pageno \else
+ \begingroup
+ \evenheadline={\hfil}\evenfootline={\hfil}%
+ \oddheadline={\hfil}\oddfootline={\hfil}%
+ \hbox to 0pt{}%
+ \chappager
+ \endgroup
+ \fi
+}
+
+\def\setchapternewpage #1 {\csname CHAPPAG#1\endcsname}
+
+\def\CHAPPAGoff{%
+\global\let\contentsalignmacro = \chappager
+\global\let\pchapsepmacro=\chapbreak
+\global\let\pagealignmacro=\chappager}
+
+\def\CHAPPAGon{%
+\global\let\contentsalignmacro = \chappager
+\global\let\pchapsepmacro=\chappager
+\global\let\pagealignmacro=\chappager
+\global\def\HEADINGSon{\HEADINGSsingle}}
+
+\def\CHAPPAGodd{%
+\global\let\contentsalignmacro = \chapoddpage
+\global\let\pchapsepmacro=\chapoddpage
+\global\let\pagealignmacro=\chapoddpage
+\global\def\HEADINGSon{\HEADINGSdouble}}
+
+\CHAPPAGon
+
+% Chapter opening.
+%
+% #1 is the text, #2 is the section type (Ynumbered, Ynothing,
+% Yappendix, Yomitfromtoc), #3 the chapter number.
+%
+% To test against our argument.
+\def\Ynothingkeyword{Ynothing}
+\def\Yomitfromtockeyword{Yomitfromtoc}
+\def\Yappendixkeyword{Yappendix}
+%
+\def\chapmacro#1#2#3{%
+ % Insert the first mark before the heading break (see notes for \domark).
+ \let\prevchapterdefs=\lastchapterdefs
+ \let\prevsectiondefs=\lastsectiondefs
+ \gdef\lastsectiondefs{\gdef\thissectionname{}\gdef\thissectionnum{}%
+ \gdef\thissection{}}%
+ %
+ \def\temptype{#2}%
+ \ifx\temptype\Ynothingkeyword
+ \gdef\lastchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}%
+ \gdef\thischapter{\thischaptername}}%
+ \else\ifx\temptype\Yomitfromtockeyword
+ \gdef\lastchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}%
+ \gdef\thischapter{}}%
+ \else\ifx\temptype\Yappendixkeyword
+ \toks0={#1}%
+ \xdef\lastchapterdefs{%
+ \gdef\noexpand\thischaptername{\the\toks0}%
+ \gdef\noexpand\thischapternum{\appendixletter}%
+ \gdef\noexpand\thischapter{\putwordAppendix{} \noexpand\thischapternum:
+ \noexpand\thischaptername}%
+ }%
+ \else
+ \toks0={#1}%
+ \xdef\lastchapterdefs{%
+ \gdef\noexpand\thischaptername{\the\toks0}%
+ \gdef\noexpand\thischapternum{\the\chapno}%
+ \gdef\noexpand\thischapter{\putwordChapter{} \noexpand\thischapternum:
+ \noexpand\thischaptername}%
+ }%
+ \fi\fi\fi
+ %
+ % Output the mark. Pass it through \safewhatsit, to take care of
+ % the preceding space.
+ \safewhatsit\domark
+ %
+ % Insert the chapter heading break.
+ \pchapsepmacro
+ %
+ % Now the second mark, after the heading break. No break points
+ % between here and the heading.
+ \let\prevchapterdefs=\lastchapterdefs
+ \let\prevsectiondefs=\lastsectiondefs
+ \domark
+ %
+ {%
+ \chapfonts \rm
+ %
+ % Have to define \lastsection before calling \donoderef, because the
+ % xref code eventually uses it. On the other hand, it has to be called
+ % after \pchapsepmacro, or the headline will change too soon.
+ \gdef\lastsection{#1}%
+ %
+ % Only insert the separating space if we have a chapter/appendix
+ % number, and don't print the unnumbered ``number''.
+ \ifx\temptype\Ynothingkeyword
+ \setbox0 = \hbox{}%
+ \def\toctype{unnchap}%
+ \else\ifx\temptype\Yomitfromtockeyword
+ \setbox0 = \hbox{}% contents like unnumbered, but no toc entry
+ \def\toctype{omit}%
+ \else\ifx\temptype\Yappendixkeyword
+ \setbox0 = \hbox{\putwordAppendix{} #3\enspace}%
+ \def\toctype{app}%
+ \else
+ \setbox0 = \hbox{#3\enspace}%
+ \def\toctype{numchap}%
+ \fi\fi\fi
+ %
+ % Write the toc entry for this chapter. Must come before the
+ % \donoderef, because we include the current node name in the toc
+ % entry, and \donoderef resets it to empty.
+ \writetocentry{\toctype}{#1}{#3}%
+ %
+ % For pdftex, we have to write out the node definition (aka, make
+ % the pdfdest) after any page break, but before the actual text has
+ % been typeset. If the destination for the pdf outline is after the
+ % text, then jumping from the outline may wind up with the text not
+ % being visible, for instance under high magnification.
+ \donoderef{#2}%
+ %
+ % Typeset the actual heading.
+ \nobreak % Avoid page breaks at the interline glue.
+ \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \raggedright
+ \hangindent=\wd0 \centerparametersmaybe
+ \unhbox0 #1\par}%
+ }%
+ \nobreak\bigskip % no page break after a chapter title
+ \nobreak
+}
+
+% @centerchap -- centered and unnumbered.
+\let\centerparametersmaybe = \relax
+\def\centerparameters{%
+ \advance\rightskip by 3\rightskip
+ \leftskip = \rightskip
+ \parfillskip = 0pt
+}
+
+
+% I don't think this chapter style is supported any more, so I'm not
+% updating it with the new noderef stuff. We'll see. --karl, 11aug03.
+%
+\def\setchapterstyle #1 {\csname CHAPF#1\endcsname}
+%
+\def\unnchfopen #1{%
+\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
+ \parindent=0pt\raggedright
+ \rm #1\hfill}}\bigskip \par\nobreak
+}
+\def\chfopen #1#2{\chapoddpage {\chapfonts
+\vbox to 3in{\vfil \hbox to\hsize{\hfil #2} \hbox to\hsize{\hfil #1} \vfil}}%
+\par\penalty 5000 %
+}
+\def\centerchfopen #1{%
+\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
+ \parindent=0pt
+ \hfill {\rm #1}\hfill}}\bigskip \par\nobreak
+}
+\def\CHAPFopen{%
+ \global\let\chapmacro=\chfopen
+ \global\let\centerchapmacro=\centerchfopen}
+
+
+% Section titles. These macros combine the section number parts and
+% call the generic \sectionheading to do the printing.
+%
+\newskip\secheadingskip
+\def\secheadingbreak{\dobreak \secheadingskip{-1000}}
+
+% Subsection titles.
+\newskip\subsecheadingskip
+\def\subsecheadingbreak{\dobreak \subsecheadingskip{-500}}
+
+% Subsubsection titles.
+\def\subsubsecheadingskip{\subsecheadingskip}
+\def\subsubsecheadingbreak{\subsecheadingbreak}
+
+
+% Print any size, any type, section title.
+%
+% #1 is the text, #2 is the section level (sec/subsec/subsubsec), #3 is
+% the section type for xrefs (Ynumbered, Ynothing, Yappendix), #4 is the
+% section number.
+%
+\def\seckeyword{sec}
+%
+\def\sectionheading#1#2#3#4{%
+ {%
+ % Switch to the right set of fonts.
+ \csname #2fonts\endcsname \rm
+ %
+ \def\sectionlevel{#2}%
+ \def\temptype{#3}%
+ %
+ % Insert first mark before the heading break (see notes for \domark).
+ \let\prevsectiondefs=\lastsectiondefs
+ \ifx\temptype\Ynothingkeyword
+ \ifx\sectionlevel\seckeyword
+ \gdef\lastsectiondefs{\gdef\thissectionname{#1}\gdef\thissectionnum{}%
+ \gdef\thissection{\thissectionname}}%
+ \fi
+ \else\ifx\temptype\Yomitfromtockeyword
+ % Don't redefine \thissection.
+ \else\ifx\temptype\Yappendixkeyword
+ \ifx\sectionlevel\seckeyword
+ \toks0={#1}%
+ \xdef\lastsectiondefs{%
+ \gdef\noexpand\thissectionname{\the\toks0}%
+ \gdef\noexpand\thissectionnum{#4}%
+ \gdef\noexpand\thissection{\putwordSection{} \noexpand\thissectionnum:
+ \noexpand\thissectionname}%
+ }%
+ \fi
+ \else
+ \ifx\sectionlevel\seckeyword
+ \toks0={#1}%
+ \xdef\lastsectiondefs{%
+ \gdef\noexpand\thissectionname{\the\toks0}%
+ \gdef\noexpand\thissectionnum{#4}%
+ \gdef\noexpand\thissection{\putwordSection{} \noexpand\thissectionnum:
+ \noexpand\thissectionname}%
+ }%
+ \fi
+ \fi\fi\fi
+ %
+ % Output the mark. Pass it through \safewhatsit, to take care of
+ % the preceding space.
+ \safewhatsit\domark
+ %
+ % Insert space above the heading.
+ \csname #2headingbreak\endcsname
+ %
+ % Now the second mark, after the heading break. No break points
+ % between here and the heading.
+ \let\prevsectiondefs=\lastsectiondefs
+ \domark
+ %
+ % Only insert the space after the number if we have a section number.
+ \ifx\temptype\Ynothingkeyword
+ \setbox0 = \hbox{}%
+ \def\toctype{unn}%
+ \gdef\lastsection{#1}%
+ \else\ifx\temptype\Yomitfromtockeyword
+ % for @headings -- no section number, don't include in toc,
+ % and don't redefine \lastsection.
+ \setbox0 = \hbox{}%
+ \def\toctype{omit}%
+ \let\sectionlevel=\empty
+ \else\ifx\temptype\Yappendixkeyword
+ \setbox0 = \hbox{#4\enspace}%
+ \def\toctype{app}%
+ \gdef\lastsection{#1}%
+ \else
+ \setbox0 = \hbox{#4\enspace}%
+ \def\toctype{num}%
+ \gdef\lastsection{#1}%
+ \fi\fi\fi
+ %
+ % Write the toc entry (before \donoderef). See comments in \chapmacro.
+ \writetocentry{\toctype\sectionlevel}{#1}{#4}%
+ %
+ % Write the node reference (= pdf destination for pdftex).
+ % Again, see comments in \chapmacro.
+ \donoderef{#3}%
+ %
+ % Interline glue will be inserted when the vbox is completed.
+ % That glue will be a valid breakpoint for the page, since it'll be
+ % preceded by a whatsit (usually from the \donoderef, or from the
+ % \writetocentry if there was no node). We don't want to allow that
+ % break, since then the whatsits could end up on page n while the
+ % section is on page n+1, thus toc/etc. are wrong. Debian bug 276000.
+ \nobreak
+ %
+ % Output the actual section heading.
+ \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \raggedright
+ \hangindent=\wd0 % zero if no section number
+ \unhbox0 #1}%
+ }%
+ % Add extra space after the heading -- half of whatever came above it.
+ % Don't allow stretch, though.
+ \kern .5 \csname #2headingskip\endcsname
+ %
+ % Do not let the kern be a potential breakpoint, as it would be if it
+ % was followed by glue.
+ \nobreak
+ %
+ % We'll almost certainly start a paragraph next, so don't let that
+ % glue accumulate. (Not a breakpoint because it's preceded by a
+ % discardable item.)
+ \vskip-\parskip
+ %
+ % This is purely so the last item on the list is a known \penalty >
+ % 10000. This is so \startdefun can avoid allowing breakpoints after
+ % section headings. Otherwise, it would insert a valid breakpoint between:
+ %
+ % @section sec-whatever
+ % @deffn def-whatever
+ \penalty 10001
+}
+
+
+\message{toc,}
+% Table of contents.
+\newwrite\tocfile
+
+% Write an entry to the toc file, opening it if necessary.
+% Called from @chapter, etc.
+%
+% Example usage: \writetocentry{sec}{Section Name}{\the\chapno.\the\secno}
+% We append the current node name (if any) and page number as additional
+% arguments for the \{chap,sec,...}entry macros which will eventually
+% read this. The node name is used in the pdf outlines as the
+% destination to jump to.
+%
+% We open the .toc file for writing here instead of at @setfilename (or
+% any other fixed time) so that @contents can be anywhere in the document.
+% But if #1 is `omit', then we don't do anything. This is used for the
+% table of contents chapter openings themselves.
+%
+\newif\iftocfileopened
+\def\omitkeyword{omit}%
+%
+\def\writetocentry#1#2#3{%
+ \edef\writetoctype{#1}%
+ \ifx\writetoctype\omitkeyword \else
+ \iftocfileopened\else
+ \immediate\openout\tocfile = \jobname.toc
+ \global\tocfileopenedtrue
+ \fi
+ %
+ \iflinks
+ {\atdummies
+ \edef\temp{%
+ \write\tocfile{@#1entry{#2}{#3}{\lastnode}{\noexpand\folio}}}%
+ \temp
+ }%
+ \fi
+ \fi
+ %
+ % Tell \shipout to create a pdf destination on each page, if we're
+ % writing pdf. These are used in the table of contents. We can't
+ % just write one on every page because the title pages are numbered
+ % 1 and 2 (the page numbers aren't printed), and so are the first
+ % two pages of the document. Thus, we'd have two destinations named
+ % `1', and two named `2'.
+ \ifpdf \global\pdfmakepagedesttrue \fi
+}
+
+
+% These characters do not print properly in the Computer Modern roman
+% fonts, so we must take special care. This is more or less redundant
+% with the Texinfo input format setup at the end of this file.
+%
+\def\activecatcodes{%
+ \catcode`\"=\active
+ \catcode`\$=\active
+ \catcode`\<=\active
+ \catcode`\>=\active
+ \catcode`\\=\active
+ \catcode`\^=\active
+ \catcode`\_=\active
+ \catcode`\|=\active
+ \catcode`\~=\active
+}
+
+
+% Read the toc file, which is essentially Texinfo input.
+\def\readtocfile{%
+ \setupdatafile
+ \activecatcodes
+ \input \tocreadfilename
+}
+
+\newskip\contentsrightmargin \contentsrightmargin=1in
+\newcount\savepageno
+\newcount\lastnegativepageno \lastnegativepageno = -1
+
+% Prepare to read what we've written to \tocfile.
+%
+\def\startcontents#1{%
+ % If @setchapternewpage on, and @headings double, the contents should
+ % start on an odd page, unlike chapters. Thus, we maintain
+ % \contentsalignmacro in parallel with \pagealignmacro.
+ % From: Torbjorn Granlund <tege@matematik.su.se>
+ \contentsalignmacro
+ \immediate\closeout\tocfile
+ %
+ % Don't need to put `Contents' or `Short Contents' in the headline.
+ % It is abundantly clear what they are.
+ \chapmacro{#1}{Yomitfromtoc}{}%
+ %
+ \savepageno = \pageno
+ \begingroup % Set up to handle contents files properly.
+ \raggedbottom % Worry more about breakpoints than the bottom.
+ \advance\hsize by -\contentsrightmargin % Don't use the full line length.
+ %
+ % Roman numerals for page numbers.
+ \ifnum \pageno>0 \global\pageno = \lastnegativepageno \fi
+}
+
+% redefined for the two-volume lispref. We always output on
+% \jobname.toc even if this is redefined.
+%
+\def\tocreadfilename{\jobname.toc}
+
+% Normal (long) toc.
+%
+\def\contents{%
+ \startcontents{\putwordTOC}%
+ \openin 1 \tocreadfilename\space
+ \ifeof 1 \else
+ \readtocfile
+ \fi
+ \vfill \eject
+ \contentsalignmacro % in case @setchapternewpage odd is in effect
+ \ifeof 1 \else
+ \pdfmakeoutlines
+ \fi
+ \closein 1
+ \endgroup
+ \lastnegativepageno = \pageno
+ \global\pageno = \savepageno
+}
+
+% And just the chapters.
+\def\summarycontents{%
+ \startcontents{\putwordShortTOC}%
+ %
+ \let\numchapentry = \shortchapentry
+ \let\appentry = \shortchapentry
+ \let\unnchapentry = \shortunnchapentry
+ % We want a true roman here for the page numbers.
+ \secfonts
+ \let\rm=\shortcontrm \let\bf=\shortcontbf
+ \let\sl=\shortcontsl \let\tt=\shortconttt
+ \rm
+ \hyphenpenalty = 10000
+ \advance\baselineskip by 1pt % Open it up a little.
+ \def\numsecentry##1##2##3##4{}
+ \let\appsecentry = \numsecentry
+ \let\unnsecentry = \numsecentry
+ \let\numsubsecentry = \numsecentry
+ \let\appsubsecentry = \numsecentry
+ \let\unnsubsecentry = \numsecentry
+ \let\numsubsubsecentry = \numsecentry
+ \let\appsubsubsecentry = \numsecentry
+ \let\unnsubsubsecentry = \numsecentry
+ \openin 1 \tocreadfilename\space
+ \ifeof 1 \else
+ \readtocfile
+ \fi
+ \closein 1
+ \vfill \eject
+ \contentsalignmacro % in case @setchapternewpage odd is in effect
+ \endgroup
+ \lastnegativepageno = \pageno
+ \global\pageno = \savepageno
+}
+\let\shortcontents = \summarycontents
+
+% Typeset the label for a chapter or appendix for the short contents.
+% The arg is, e.g., `A' for an appendix, or `3' for a chapter.
+%
+\def\shortchaplabel#1{%
+ % This space should be enough, since a single number is .5em, and the
+ % widest letter (M) is 1em, at least in the Computer Modern fonts.
+ % But use \hss just in case.
+ % (This space doesn't include the extra space that gets added after
+ % the label; that gets put in by \shortchapentry above.)
+ %
+ % We'd like to right-justify chapter numbers, but that looks strange
+ % with appendix letters. And right-justifying numbers and
+ % left-justifying letters looks strange when there is less than 10
+ % chapters. Have to read the whole toc once to know how many chapters
+ % there are before deciding ...
+ \hbox to 1em{#1\hss}%
+}
+
+% These macros generate individual entries in the table of contents.
+% The first argument is the chapter or section name.
+% The last argument is the page number.
+% The arguments in between are the chapter number, section number, ...
+
+% Chapters, in the main contents.
+\def\numchapentry#1#2#3#4{\dochapentry{#2\labelspace#1}{#4}}
+%
+% Chapters, in the short toc.
+% See comments in \dochapentry re vbox and related settings.
+\def\shortchapentry#1#2#3#4{%
+ \tocentry{\shortchaplabel{#2}\labelspace #1}{\doshortpageno\bgroup#4\egroup}%
+}
+
+% Appendices, in the main contents.
+% Need the word Appendix, and a fixed-size box.
+%
+\def\appendixbox#1{%
+ % We use M since it's probably the widest letter.
+ \setbox0 = \hbox{\putwordAppendix{} M}%
+ \hbox to \wd0{\putwordAppendix{} #1\hss}}
+%
+\def\appentry#1#2#3#4{\dochapentry{\appendixbox{#2}\labelspace#1}{#4}}
+
+% Unnumbered chapters.
+\def\unnchapentry#1#2#3#4{\dochapentry{#1}{#4}}
+\def\shortunnchapentry#1#2#3#4{\tocentry{#1}{\doshortpageno\bgroup#4\egroup}}
+
+% Sections.
+\def\numsecentry#1#2#3#4{\dosecentry{#2\labelspace#1}{#4}}
+\let\appsecentry=\numsecentry
+\def\unnsecentry#1#2#3#4{\dosecentry{#1}{#4}}
+
+% Subsections.
+\def\numsubsecentry#1#2#3#4{\dosubsecentry{#2\labelspace#1}{#4}}
+\let\appsubsecentry=\numsubsecentry
+\def\unnsubsecentry#1#2#3#4{\dosubsecentry{#1}{#4}}
+
+% And subsubsections.
+\def\numsubsubsecentry#1#2#3#4{\dosubsubsecentry{#2\labelspace#1}{#4}}
+\let\appsubsubsecentry=\numsubsubsecentry
+\def\unnsubsubsecentry#1#2#3#4{\dosubsubsecentry{#1}{#4}}
+
+% This parameter controls the indentation of the various levels.
+% Same as \defaultparindent.
+\newdimen\tocindent \tocindent = 15pt
+
+% Now for the actual typesetting. In all these, #1 is the text and #2 is the
+% page number.
+%
+% If the toc has to be broken over pages, we want it to be at chapters
+% if at all possible; hence the \penalty.
+\def\dochapentry#1#2{%
+ \penalty-300 \vskip1\baselineskip plus.33\baselineskip minus.25\baselineskip
+ \begingroup
+ \chapentryfonts
+ \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+ \endgroup
+ \nobreak\vskip .25\baselineskip plus.1\baselineskip
+}
+
+\def\dosecentry#1#2{\begingroup
+ \secentryfonts \leftskip=\tocindent
+ \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+\endgroup}
+
+\def\dosubsecentry#1#2{\begingroup
+ \subsecentryfonts \leftskip=2\tocindent
+ \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+\endgroup}
+
+\def\dosubsubsecentry#1#2{\begingroup
+ \subsubsecentryfonts \leftskip=3\tocindent
+ \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+\endgroup}
+
+% We use the same \entry macro as for the index entries.
+\let\tocentry = \entry
+
+% Space between chapter (or whatever) number and the title.
+\def\labelspace{\hskip1em \relax}
+
+\def\dopageno#1{{\rm #1}}
+\def\doshortpageno#1{{\rm #1}}
+
+\def\chapentryfonts{\secfonts \rm}
+\def\secentryfonts{\textfonts}
+\def\subsecentryfonts{\textfonts}
+\def\subsubsecentryfonts{\textfonts}
+
+
+\message{environments,}
+% @foo ... @end foo.
+
+% @point{}, @result{}, @expansion{}, @print{}, @equiv{}.
+%
+% Since these characters are used in examples, it should be an even number of
+% \tt widths. Each \tt character is 1en, so two makes it 1em.
+%
+\def\point{$\star$}
+\def\result{\leavevmode\raise.15ex\hbox to 1em{\hfil$\Rightarrow$\hfil}}
+\def\expansion{\leavevmode\raise.1ex\hbox to 1em{\hfil$\mapsto$\hfil}}
+\def\print{\leavevmode\lower.1ex\hbox to 1em{\hfil$\dashv$\hfil}}
+\def\equiv{\leavevmode\lower.1ex\hbox to 1em{\hfil$\ptexequiv$\hfil}}
+
+% The @error{} command.
+% Adapted from the TeXbook's \boxit.
+%
+\newbox\errorbox
+%
+{\tentt \global\dimen0 = 3em}% Width of the box.
+\dimen2 = .55pt % Thickness of rules
+% The text. (`r' is open on the right, `e' somewhat less so on the left.)
+\setbox0 = \hbox{\kern-.75pt \reducedsf error\kern-1.5pt}
+%
+\setbox\errorbox=\hbox to \dimen0{\hfil
+ \hsize = \dimen0 \advance\hsize by -5.8pt % Space to left+right.
+ \advance\hsize by -2\dimen2 % Rules.
+ \vbox{%
+ \hrule height\dimen2
+ \hbox{\vrule width\dimen2 \kern3pt % Space to left of text.
+ \vtop{\kern2.4pt \box0 \kern2.4pt}% Space above/below.
+ \kern3pt\vrule width\dimen2}% Space to right.
+ \hrule height\dimen2}
+ \hfil}
+%
+\def\error{\leavevmode\lower.7ex\copy\errorbox}
+
+% @tex ... @end tex escapes into raw Tex temporarily.
+% One exception: @ is still an escape character, so that @end tex works.
+% But \@ or @@ will get a plain tex @ character.
+
+\envdef\tex{%
+ \catcode `\\=0 \catcode `\{=1 \catcode `\}=2
+ \catcode `\$=3 \catcode `\&=4 \catcode `\#=6
+ \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie
+ \catcode `\%=14
+ \catcode `\+=\other
+ \catcode `\"=\other
+ \catcode `\|=\other
+ \catcode `\<=\other
+ \catcode `\>=\other
+ \escapechar=`\\
+ %
+ \let\b=\ptexb
+ \let\bullet=\ptexbullet
+ \let\c=\ptexc
+ \let\,=\ptexcomma
+ \let\.=\ptexdot
+ \let\dots=\ptexdots
+ \let\equiv=\ptexequiv
+ \let\!=\ptexexclam
+ \let\i=\ptexi
+ \let\indent=\ptexindent
+ \let\noindent=\ptexnoindent
+ \let\{=\ptexlbrace
+ \let\+=\tabalign
+ \let\}=\ptexrbrace
+ \let\/=\ptexslash
+ \let\*=\ptexstar
+ \let\t=\ptext
+ \let\frenchspacing=\plainfrenchspacing
+ %
+ \def\endldots{\mathinner{\ldots\ldots\ldots\ldots}}%
+ \def\enddots{\relax\ifmmode\endldots\else$\mathsurround=0pt \endldots\,$\fi}%
+ \def\@{@}%
+}
+% There is no need to define \Etex.
+
+% Define @lisp ... @end lisp.
+% @lisp environment forms a group so it can rebind things,
+% including the definition of @end lisp (which normally is erroneous).
+
+% Amount to narrow the margins by for @lisp.
+\newskip\lispnarrowing \lispnarrowing=0.4in
+
+% This is the definition that ^^M gets inside @lisp, @example, and other
+% such environments. \null is better than a space, since it doesn't
+% have any width.
+\def\lisppar{\null\endgraf}
+
+% This space is always present above and below environments.
+\newskip\envskipamount \envskipamount = 0pt
+
+% Make spacing and below environment symmetrical. We use \parskip here
+% to help in doing that, since in @example-like environments \parskip
+% is reset to zero; thus the \afterenvbreak inserts no space -- but the
+% start of the next paragraph will insert \parskip.
+%
+\def\aboveenvbreak{{%
+ % =10000 instead of <10000 because of a special case in \itemzzz and
+ % \sectionheading, q.v.
+ \ifnum \lastpenalty=10000 \else
+ \advance\envskipamount by \parskip
+ \endgraf
+ \ifdim\lastskip<\envskipamount
+ \removelastskip
+ % it's not a good place to break if the last penalty was \nobreak
+ % or better ...
+ \ifnum\lastpenalty<10000 \penalty-50 \fi
+ \vskip\envskipamount
+ \fi
+ \fi
+}}
+
+\let\afterenvbreak = \aboveenvbreak
+
+% \nonarrowing is a flag. If "set", @lisp etc don't narrow margins; it will
+% also clear it, so that its embedded environments do the narrowing again.
+\let\nonarrowing=\relax
+
+% @cartouche ... @end cartouche: draw rectangle w/rounded corners around
+% environment contents.
+\font\circle=lcircle10
+\newdimen\circthick
+\newdimen\cartouter\newdimen\cartinner
+\newskip\normbskip\newskip\normpskip\newskip\normlskip
+\circthick=\fontdimen8\circle
+%
+\def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth
+\def\ctr{{\hskip 6pt\circle\char'010}}
+\def\cbl{{\circle\char'012\hskip -6pt}}
+\def\cbr{{\hskip 6pt\circle\char'011}}
+\def\carttop{\hbox to \cartouter{\hskip\lskip
+ \ctl\leaders\hrule height\circthick\hfil\ctr
+ \hskip\rskip}}
+\def\cartbot{\hbox to \cartouter{\hskip\lskip
+ \cbl\leaders\hrule height\circthick\hfil\cbr
+ \hskip\rskip}}
+%
+\newskip\lskip\newskip\rskip
+
+\envdef\cartouche{%
+ \ifhmode\par\fi % can't be in the midst of a paragraph.
+ \startsavinginserts
+ \lskip=\leftskip \rskip=\rightskip
+ \leftskip=0pt\rightskip=0pt % we want these *outside*.
+ \cartinner=\hsize \advance\cartinner by-\lskip
+ \advance\cartinner by-\rskip
+ \cartouter=\hsize
+ \advance\cartouter by 18.4pt % allow for 3pt kerns on either
+ % side, and for 6pt waste from
+ % each corner char, and rule thickness
+ \normbskip=\baselineskip \normpskip=\parskip \normlskip=\lineskip
+ % Flag to tell @lisp, etc., not to narrow margin.
+ \let\nonarrowing = t%
+ \vbox\bgroup
+ \baselineskip=0pt\parskip=0pt\lineskip=0pt
+ \carttop
+ \hbox\bgroup
+ \hskip\lskip
+ \vrule\kern3pt
+ \vbox\bgroup
+ \kern3pt
+ \hsize=\cartinner
+ \baselineskip=\normbskip
+ \lineskip=\normlskip
+ \parskip=\normpskip
+ \vskip -\parskip
+ \comment % For explanation, see the end of \def\group.
+}
+\def\Ecartouche{%
+ \ifhmode\par\fi
+ \kern3pt
+ \egroup
+ \kern3pt\vrule
+ \hskip\rskip
+ \egroup
+ \cartbot
+ \egroup
+ \checkinserts
+}
+
+
+% This macro is called at the beginning of all the @example variants,
+% inside a group.
+\def\nonfillstart{%
+ \aboveenvbreak
+ \hfuzz = 12pt % Don't be fussy
+ \sepspaces % Make spaces be word-separators rather than space tokens.
+ \let\par = \lisppar % don't ignore blank lines
+ \obeylines % each line of input is a line of output
+ \parskip = 0pt
+ \parindent = 0pt
+ \emergencystretch = 0pt % don't try to avoid overfull boxes
+ \ifx\nonarrowing\relax
+ \advance \leftskip by \lispnarrowing
+ \exdentamount=\lispnarrowing
+ \else
+ \let\nonarrowing = \relax
+ \fi
+ \let\exdent=\nofillexdent
+}
+
+% If you want all examples etc. small: @set dispenvsize small.
+% If you want even small examples the full size: @set dispenvsize nosmall.
+% This affects the following displayed environments:
+% @example, @display, @format, @lisp
+%
+\def\smallword{small}
+\def\nosmallword{nosmall}
+\let\SETdispenvsize\relax
+\def\setnormaldispenv{%
+ \ifx\SETdispenvsize\smallword
+ % end paragraph for sake of leading, in case document has no blank
+ % line. This is redundant with what happens in \aboveenvbreak, but
+ % we need to do it before changing the fonts, and it's inconvenient
+ % to change the fonts afterward.
+ \ifnum \lastpenalty=10000 \else \endgraf \fi
+ \smallexamplefonts \rm
+ \fi
+}
+\def\setsmalldispenv{%
+ \ifx\SETdispenvsize\nosmallword
+ \else
+ \ifnum \lastpenalty=10000 \else \endgraf \fi
+ \smallexamplefonts \rm
+ \fi
+}
+
+% We often define two environments, @foo and @smallfoo.
+% Let's do it by one command:
+\def\makedispenv #1#2{
+ \expandafter\envdef\csname#1\endcsname {\setnormaldispenv #2}
+ \expandafter\envdef\csname small#1\endcsname {\setsmalldispenv #2}
+ \expandafter\let\csname E#1\endcsname \afterenvbreak
+ \expandafter\let\csname Esmall#1\endcsname \afterenvbreak
+}
+
+% Define two synonyms:
+\def\maketwodispenvs #1#2#3{
+ \makedispenv{#1}{#3}
+ \makedispenv{#2}{#3}
+}
+
+% @lisp: indented, narrowed, typewriter font; @example: same as @lisp.
+%
+% @smallexample and @smalllisp: use smaller fonts.
+% Originally contributed by Pavel@xerox.
+%
+\maketwodispenvs {lisp}{example}{%
+ \nonfillstart
+ \tt\quoteexpand
+ \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special.
+ \gobble % eat return
+}
+% @display/@smalldisplay: same as @lisp except keep current font.
+%
+\makedispenv {display}{%
+ \nonfillstart
+ \gobble
+}
+
+% @format/@smallformat: same as @display except don't narrow margins.
+%
+\makedispenv{format}{%
+ \let\nonarrowing = t%
+ \nonfillstart
+ \gobble
+}
+
+% @flushleft: same as @format, but doesn't obey \SETdispenvsize.
+\envdef\flushleft{%
+ \let\nonarrowing = t%
+ \nonfillstart
+ \gobble
+}
+\let\Eflushleft = \afterenvbreak
+
+% @flushright.
+%
+\envdef\flushright{%
+ \let\nonarrowing = t%
+ \nonfillstart
+ \advance\leftskip by 0pt plus 1fill
+ \gobble
+}
+\let\Eflushright = \afterenvbreak
+
+
+% @quotation does normal linebreaking (hence we can't use \nonfillstart)
+% and narrows the margins. We keep \parskip nonzero in general, since
+% we're doing normal filling. So, when using \aboveenvbreak and
+% \afterenvbreak, temporarily make \parskip 0.
+%
+\envdef\quotation{%
+ {\parskip=0pt \aboveenvbreak}% because \aboveenvbreak inserts \parskip
+ \parindent=0pt
+ %
+ % @cartouche defines \nonarrowing to inhibit narrowing at next level down.
+ \ifx\nonarrowing\relax
+ \advance\leftskip by \lispnarrowing
+ \advance\rightskip by \lispnarrowing
+ \exdentamount = \lispnarrowing
+ \else
+ \let\nonarrowing = \relax
+ \fi
+ \parsearg\quotationlabel
+}
+
+% We have retained a nonzero parskip for the environment, since we're
+% doing normal filling.
+%
+\def\Equotation{%
+ \par
+ \ifx\quotationauthor\undefined\else
+ % indent a bit.
+ \leftline{\kern 2\leftskip \sl ---\quotationauthor}%
+ \fi
+ {\parskip=0pt \afterenvbreak}%
+}
+
+% If we're given an argument, typeset it in bold with a colon after.
+\def\quotationlabel#1{%
+ \def\temp{#1}%
+ \ifx\temp\empty \else
+ {\bf #1: }%
+ \fi
+}
+
+
+% LaTeX-like @verbatim...@end verbatim and @verb{<char>...<char>}
+% If we want to allow any <char> as delimiter,
+% we need the curly braces so that makeinfo sees the @verb command, eg:
+% `@verbx...x' would look like the '@verbx' command. --janneke@gnu.org
+%
+% [Knuth]: Donald Ervin Knuth, 1996. The TeXbook.
+%
+% [Knuth] p.344; only we need to do the other characters Texinfo sets
+% active too. Otherwise, they get lost as the first character on a
+% verbatim line.
+\def\dospecials{%
+ \do\ \do\\\do\{\do\}\do\$\do\&%
+ \do\#\do\^\do\^^K\do\_\do\^^A\do\%\do\~%
+ \do\<\do\>\do\|\do\@\do+\do\"%
+}
+%
+% [Knuth] p. 380
+\def\uncatcodespecials{%
+ \def\do##1{\catcode`##1=\other}\dospecials}
+%
+% [Knuth] pp. 380,381,391
+% Disable Spanish ligatures ?` and !` of \tt font
+\begingroup
+ \catcode`\`=\active\gdef`{\relax\lq}
+\endgroup
+%
+% Setup for the @verb command.
+%
+% Eight spaces for a tab
+\begingroup
+ \catcode`\^^I=\active
+ \gdef\tabeightspaces{\catcode`\^^I=\active\def^^I{\ \ \ \ \ \ \ \ }}
+\endgroup
+%
+\def\setupverb{%
+ \tt % easiest (and conventionally used) font for verbatim
+ \def\par{\leavevmode\endgraf}%
+ \catcode`\`=\active
+ \tabeightspaces
+ % Respect line breaks,
+ % print special symbols as themselves, and
+ % make each space count
+ % must do in this order:
+ \obeylines \uncatcodespecials \sepspaces
+}
+
+% Setup for the @verbatim environment
+%
+% Real tab expansion
+\newdimen\tabw \setbox0=\hbox{\tt\space} \tabw=8\wd0 % tab amount
+%
+\def\starttabbox{\setbox0=\hbox\bgroup}
+
+% Allow an option to not replace quotes with a regular directed right
+% quote/apostrophe (char 0x27), but instead use the undirected quote
+% from cmtt (char 0x0d). The undirected quote is ugly, so don't make it
+% the default, but it works for pasting with more pdf viewers (at least
+% evince), the lilypond developers report. xpdf does work with the
+% regular 0x27.
+%
+\def\codequoteright{%
+ \expandafter\ifx\csname SETtxicodequoteundirected\endcsname\relax
+ \expandafter\ifx\csname SETcodequoteundirected\endcsname\relax
+ '%
+ \else \char'15 \fi
+ \else \char'15 \fi
+}
+%
+% and a similar option for the left quote char vs. a grave accent.
+% Modern fonts display ASCII 0x60 as a grave accent, so some people like
+% the code environments to do likewise.
+%
+\def\codequoteleft{%
+ \expandafter\ifx\csname SETtxicodequotebacktick\endcsname\relax
+ \expandafter\ifx\csname SETcodequotebacktick\endcsname\relax
+ `%
+ \else \char'22 \fi
+ \else \char'22 \fi
+}
+%
+\begingroup
+ \catcode`\^^I=\active
+ \gdef\tabexpand{%
+ \catcode`\^^I=\active
+ \def^^I{\leavevmode\egroup
+ \dimen0=\wd0 % the width so far, or since the previous tab
+ \divide\dimen0 by\tabw
+ \multiply\dimen0 by\tabw % compute previous multiple of \tabw
+ \advance\dimen0 by\tabw % advance to next multiple of \tabw
+ \wd0=\dimen0 \box0 \starttabbox
+ }%
+ }
+ \catcode`\'=\active
+ \gdef\rquoteexpand{\catcode\rquoteChar=\active \def'{\codequoteright}}%
+ %
+ \catcode`\`=\active
+ \gdef\lquoteexpand{\catcode\lquoteChar=\active \def`{\codequoteleft}}%
+ %
+ \gdef\quoteexpand{\rquoteexpand \lquoteexpand}%
+\endgroup
+
+% start the verbatim environment.
+\def\setupverbatim{%
+ \let\nonarrowing = t%
+ \nonfillstart
+ % Easiest (and conventionally used) font for verbatim
+ \tt
+ \def\par{\leavevmode\egroup\box0\endgraf}%
+ \catcode`\`=\active
+ \tabexpand
+ \quoteexpand
+ % Respect line breaks,
+ % print special symbols as themselves, and
+ % make each space count
+ % must do in this order:
+ \obeylines \uncatcodespecials \sepspaces
+ \everypar{\starttabbox}%
+}
+
+% Do the @verb magic: verbatim text is quoted by unique
+% delimiter characters. Before first delimiter expect a
+% right brace, after last delimiter expect closing brace:
+%
+% \def\doverb'{'<char>#1<char>'}'{#1}
+%
+% [Knuth] p. 382; only eat outer {}
+\begingroup
+ \catcode`[=1\catcode`]=2\catcode`\{=\other\catcode`\}=\other
+ \gdef\doverb{#1[\def\next##1#1}[##1\endgroup]\next]
+\endgroup
+%
+\def\verb{\begingroup\setupverb\doverb}
+%
+%
+% Do the @verbatim magic: define the macro \doverbatim so that
+% the (first) argument ends when '@end verbatim' is reached, ie:
+%
+% \def\doverbatim#1@end verbatim{#1}
+%
+% For Texinfo it's a lot easier than for LaTeX,
+% because texinfo's \verbatim doesn't stop at '\end{verbatim}':
+% we need not redefine '\', '{' and '}'.
+%
+% Inspired by LaTeX's verbatim command set [latex.ltx]
+%
+\begingroup
+ \catcode`\ =\active
+ \obeylines %
+ % ignore everything up to the first ^^M, that's the newline at the end
+ % of the @verbatim input line itself. Otherwise we get an extra blank
+ % line in the output.
+ \xdef\doverbatim#1^^M#2@end verbatim{#2\noexpand\end\gobble verbatim}%
+ % We really want {...\end verbatim} in the body of the macro, but
+ % without the active space; thus we have to use \xdef and \gobble.
+\endgroup
+%
+\envdef\verbatim{%
+ \setupverbatim\doverbatim
+}
+\let\Everbatim = \afterenvbreak
+
+
+% @verbatiminclude FILE - insert text of file in verbatim environment.
+%
+\def\verbatiminclude{\parseargusing\filenamecatcodes\doverbatiminclude}
+%
+\def\doverbatiminclude#1{%
+ {%
+ \makevalueexpandable
+ \setupverbatim
+ \input #1
+ \afterenvbreak
+ }%
+}
+
+% @copying ... @end copying.
+% Save the text away for @insertcopying later.
+%
+% We save the uninterpreted tokens, rather than creating a box.
+% Saving the text in a box would be much easier, but then all the
+% typesetting commands (@smallbook, font changes, etc.) have to be done
+% beforehand -- and a) we want @copying to be done first in the source
+% file; b) letting users define the frontmatter in as flexible order as
+% possible is very desirable.
+%
+\def\copying{\checkenv{}\begingroup\scanargctxt\docopying}
+\def\docopying#1@end copying{\endgroup\def\copyingtext{#1}}
+%
+\def\insertcopying{%
+ \begingroup
+ \parindent = 0pt % paragraph indentation looks wrong on title page
+ \scanexp\copyingtext
+ \endgroup
+}
+
+
+\message{defuns,}
+% @defun etc.
+
+\newskip\defbodyindent \defbodyindent=.4in
+\newskip\defargsindent \defargsindent=50pt
+\newskip\deflastargmargin \deflastargmargin=18pt
+\newcount\defunpenalty
+
+% Start the processing of @deffn:
+\def\startdefun{%
+ \ifnum\lastpenalty<10000
+ \medbreak
+ \defunpenalty=10003 % Will keep this @deffn together with the
+ % following @def command, see below.
+ \else
+ % If there are two @def commands in a row, we'll have a \nobreak,
+ % which is there to keep the function description together with its
+ % header. But if there's nothing but headers, we need to allow a
+ % break somewhere. Check specifically for penalty 10002, inserted
+ % by \printdefunline, instead of 10000, since the sectioning
+ % commands also insert a nobreak penalty, and we don't want to allow
+ % a break between a section heading and a defun.
+ %
+ % As a minor refinement, we avoid "club" headers by signalling
+ % with penalty of 10003 after the very first @deffn in the
+ % sequence (see above), and penalty of 10002 after any following
+ % @def command.
+ \ifnum\lastpenalty=10002 \penalty2000 \else \defunpenalty=10002 \fi
+ %
+ % Similarly, after a section heading, do not allow a break.
+ % But do insert the glue.
+ \medskip % preceded by discardable penalty, so not a breakpoint
+ \fi
+ %
+ \parindent=0in
+ \advance\leftskip by \defbodyindent
+ \exdentamount=\defbodyindent
+}
+
+\def\dodefunx#1{%
+ % First, check whether we are in the right environment:
+ \checkenv#1%
+ %
+ % As above, allow line break if we have multiple x headers in a row.
+ % It's not a great place, though.
+ \ifnum\lastpenalty=10002 \penalty3000 \else \defunpenalty=10002 \fi
+ %
+ % And now, it's time to reuse the body of the original defun:
+ \expandafter\gobbledefun#1%
+}
+\def\gobbledefun#1\startdefun{}
+
+% \printdefunline \deffnheader{text}
+%
+\def\printdefunline#1#2{%
+ \begingroup
+ % call \deffnheader:
+ #1#2 \endheader
+ % common ending:
+ \interlinepenalty = 10000
+ \advance\rightskip by 0pt plus 1fil
+ \endgraf
+ \nobreak\vskip -\parskip
+ \penalty\defunpenalty % signal to \startdefun and \dodefunx
+ % Some of the @defun-type tags do not enable magic parentheses,
+ % rendering the following check redundant. But we don't optimize.
+ \checkparencounts
+ \endgroup
+}
+
+\def\Edefun{\endgraf\medbreak}
+
+% \makedefun{deffn} creates \deffn, \deffnx and \Edeffn;
+% the only thing remainnig is to define \deffnheader.
+%
+\def\makedefun#1{%
+ \expandafter\let\csname E#1\endcsname = \Edefun
+ \edef\temp{\noexpand\domakedefun
+ \makecsname{#1}\makecsname{#1x}\makecsname{#1header}}%
+ \temp
+}
+
+% \domakedefun \deffn \deffnx \deffnheader
+%
+% Define \deffn and \deffnx, without parameters.
+% \deffnheader has to be defined explicitly.
+%
+\def\domakedefun#1#2#3{%
+ \envdef#1{%
+ \startdefun
+ \parseargusing\activeparens{\printdefunline#3}%
+ }%
+ \def#2{\dodefunx#1}%
+ \def#3%
+}
+
+%%% Untyped functions:
+
+% @deffn category name args
+\makedefun{deffn}{\deffngeneral{}}
+
+% @deffn category class name args
+\makedefun{defop}#1 {\defopon{#1\ \putwordon}}
+
+% \defopon {category on}class name args
+\def\defopon#1#2 {\deffngeneral{\putwordon\ \code{#2}}{#1\ \code{#2}} }
+
+% \deffngeneral {subind}category name args
+%
+\def\deffngeneral#1#2 #3 #4\endheader{%
+ % Remember that \dosubind{fn}{foo}{} is equivalent to \doind{fn}{foo}.
+ \dosubind{fn}{\code{#3}}{#1}%
+ \defname{#2}{}{#3}\magicamp\defunargs{#4\unskip}%
+}
+
+%%% Typed functions:
+
+% @deftypefn category type name args
+\makedefun{deftypefn}{\deftypefngeneral{}}
+
+% @deftypeop category class type name args
+\makedefun{deftypeop}#1 {\deftypeopon{#1\ \putwordon}}
+
+% \deftypeopon {category on}class type name args
+\def\deftypeopon#1#2 {\deftypefngeneral{\putwordon\ \code{#2}}{#1\ \code{#2}} }
+
+% \deftypefngeneral {subind}category type name args
+%
+\def\deftypefngeneral#1#2 #3 #4 #5\endheader{%
+ \dosubind{fn}{\code{#4}}{#1}%
+ \defname{#2}{#3}{#4}\defunargs{#5\unskip}%
+}
+
+%%% Typed variables:
+
+% @deftypevr category type var args
+\makedefun{deftypevr}{\deftypecvgeneral{}}
+
+% @deftypecv category class type var args
+\makedefun{deftypecv}#1 {\deftypecvof{#1\ \putwordof}}
+
+% \deftypecvof {category of}class type var args
+\def\deftypecvof#1#2 {\deftypecvgeneral{\putwordof\ \code{#2}}{#1\ \code{#2}} }
+
+% \deftypecvgeneral {subind}category type var args
+%
+\def\deftypecvgeneral#1#2 #3 #4 #5\endheader{%
+ \dosubind{vr}{\code{#4}}{#1}%
+ \defname{#2}{#3}{#4}\defunargs{#5\unskip}%
+}
+
+%%% Untyped variables:
+
+% @defvr category var args
+\makedefun{defvr}#1 {\deftypevrheader{#1} {} }
+
+% @defcv category class var args
+\makedefun{defcv}#1 {\defcvof{#1\ \putwordof}}
+
+% \defcvof {category of}class var args
+\def\defcvof#1#2 {\deftypecvof{#1}#2 {} }
+
+%%% Type:
+% @deftp category name args
+\makedefun{deftp}#1 #2 #3\endheader{%
+ \doind{tp}{\code{#2}}%
+ \defname{#1}{}{#2}\defunargs{#3\unskip}%
+}
+
+% Remaining @defun-like shortcuts:
+\makedefun{defun}{\deffnheader{\putwordDeffunc} }
+\makedefun{defmac}{\deffnheader{\putwordDefmac} }
+\makedefun{defspec}{\deffnheader{\putwordDefspec} }
+\makedefun{deftypefun}{\deftypefnheader{\putwordDeffunc} }
+\makedefun{defvar}{\defvrheader{\putwordDefvar} }
+\makedefun{defopt}{\defvrheader{\putwordDefopt} }
+\makedefun{deftypevar}{\deftypevrheader{\putwordDefvar} }
+\makedefun{defmethod}{\defopon\putwordMethodon}
+\makedefun{deftypemethod}{\deftypeopon\putwordMethodon}
+\makedefun{defivar}{\defcvof\putwordInstanceVariableof}
+\makedefun{deftypeivar}{\deftypecvof\putwordInstanceVariableof}
+
+% \defname, which formats the name of the @def (not the args).
+% #1 is the category, such as "Function".
+% #2 is the return type, if any.
+% #3 is the function name.
+%
+% We are followed by (but not passed) the arguments, if any.
+%
+\def\defname#1#2#3{%
+ % Get the values of \leftskip and \rightskip as they were outside the @def...
+ \advance\leftskip by -\defbodyindent
+ %
+ % How we'll format the type name. Putting it in brackets helps
+ % distinguish it from the body text that may end up on the next line
+ % just below it.
+ \def\temp{#1}%
+ \setbox0=\hbox{\kern\deflastargmargin \ifx\temp\empty\else [\rm\temp]\fi}
+ %
+ % Figure out line sizes for the paragraph shape.
+ % The first line needs space for \box0; but if \rightskip is nonzero,
+ % we need only space for the part of \box0 which exceeds it:
+ \dimen0=\hsize \advance\dimen0 by -\wd0 \advance\dimen0 by \rightskip
+ % The continuations:
+ \dimen2=\hsize \advance\dimen2 by -\defargsindent
+ % (plain.tex says that \dimen1 should be used only as global.)
+ \parshape 2 0in \dimen0 \defargsindent \dimen2
+ %
+ % Put the type name to the right margin.
+ \noindent
+ \hbox to 0pt{%
+ \hfil\box0 \kern-\hsize
+ % \hsize has to be shortened this way:
+ \kern\leftskip
+ % Intentionally do not respect \rightskip, since we need the space.
+ }%
+ %
+ % Allow all lines to be underfull without complaint:
+ \tolerance=10000 \hbadness=10000
+ \exdentamount=\defbodyindent
+ {%
+ % defun fonts. We use typewriter by default (used to be bold) because:
+ % . we're printing identifiers, they should be in tt in principle.
+ % . in languages with many accents, such as Czech or French, it's
+ % common to leave accents off identifiers. The result looks ok in
+ % tt, but exceedingly strange in rm.
+ % . we don't want -- and --- to be treated as ligatures.
+ % . this still does not fix the ?` and !` ligatures, but so far no
+ % one has made identifiers using them :).
+ \df \tt
+ \def\temp{#2}% return value type
+ \ifx\temp\empty\else \tclose{\temp} \fi
+ #3% output function name
+ }%
+ {\rm\enskip}% hskip 0.5 em of \tenrm
+ %
+ \boldbrax
+ % arguments will be output next, if any.
+}
+
+% Print arguments in slanted roman (not ttsl), inconsistently with using
+% tt for the name. This is because literal text is sometimes needed in
+% the argument list (groff manual), and ttsl and tt are not very
+% distinguishable. Prevent hyphenation at `-' chars.
+%
+\def\defunargs#1{%
+ % use sl by default (not ttsl),
+ % tt for the names.
+ \df \sl \hyphenchar\font=0
+ %
+ % On the other hand, if an argument has two dashes (for instance), we
+ % want a way to get ttsl. Let's try @var for that.
+ \let\var=\ttslanted
+ #1%
+ \sl\hyphenchar\font=45
+}
+
+% We want ()&[] to print specially on the defun line.
+%
+\def\activeparens{%
+ \catcode`\(=\active \catcode`\)=\active
+ \catcode`\[=\active \catcode`\]=\active
+ \catcode`\&=\active
+}
+
+% Make control sequences which act like normal parenthesis chars.
+\let\lparen = ( \let\rparen = )
+
+% Be sure that we always have a definition for `(', etc. For example,
+% if the fn name has parens in it, \boldbrax will not be in effect yet,
+% so TeX would otherwise complain about undefined control sequence.
+{
+ \activeparens
+ \global\let(=\lparen \global\let)=\rparen
+ \global\let[=\lbrack \global\let]=\rbrack
+ \global\let& = \&
+
+ \gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb}
+ \gdef\magicamp{\let&=\amprm}
+}
+
+\newcount\parencount
+
+% If we encounter &foo, then turn on ()-hacking afterwards
+\newif\ifampseen
+\def\amprm#1 {\ampseentrue{\bf\ }}
+
+\def\parenfont{%
+ \ifampseen
+ % At the first level, print parens in roman,
+ % otherwise use the default font.
+ \ifnum \parencount=1 \rm \fi
+ \else
+ % The \sf parens (in \boldbrax) actually are a little bolder than
+ % the contained text. This is especially needed for [ and ] .
+ \sf
+ \fi
+}
+\def\infirstlevel#1{%
+ \ifampseen
+ \ifnum\parencount=1
+ #1%
+ \fi
+ \fi
+}
+\def\bfafterword#1 {#1 \bf}
+
+\def\opnr{%
+ \global\advance\parencount by 1
+ {\parenfont(}%
+ \infirstlevel \bfafterword
+}
+\def\clnr{%
+ {\parenfont)}%
+ \infirstlevel \sl
+ \global\advance\parencount by -1
+}
+
+\newcount\brackcount
+\def\lbrb{%
+ \global\advance\brackcount by 1
+ {\bf[}%
+}
+\def\rbrb{%
+ {\bf]}%
+ \global\advance\brackcount by -1
+}
+
+\def\checkparencounts{%
+ \ifnum\parencount=0 \else \badparencount \fi
+ \ifnum\brackcount=0 \else \badbrackcount \fi
+}
+% these should not use \errmessage; the glibc manual, at least, actually
+% has such constructs (when documenting function pointers).
+\def\badparencount{%
+ \message{Warning: unbalanced parentheses in @def...}%
+ \global\parencount=0
+}
+\def\badbrackcount{%
+ \message{Warning: unbalanced square brackets in @def...}%
+ \global\brackcount=0
+}
+
+
+\message{macros,}
+% @macro.
+
+% To do this right we need a feature of e-TeX, \scantokens,
+% which we arrange to emulate with a temporary file in ordinary TeX.
+\ifx\eTeXversion\undefined
+ \newwrite\macscribble
+ \def\scantokens#1{%
+ \toks0={#1}%
+ \immediate\openout\macscribble=\jobname.tmp
+ \immediate\write\macscribble{\the\toks0}%
+ \immediate\closeout\macscribble
+ \input \jobname.tmp
+ }
+\fi
+
+\def\scanmacro#1{%
+ \begingroup
+ \newlinechar`\^^M
+ \let\xeatspaces\eatspaces
+ % Undo catcode changes of \startcontents and \doprintindex
+ % When called from @insertcopying or (short)caption, we need active
+ % backslash to get it printed correctly. Previously, we had
+ % \catcode`\\=\other instead. We'll see whether a problem appears
+ % with macro expansion. --kasal, 19aug04
+ \catcode`\@=0 \catcode`\\=\active \escapechar=`\@
+ % ... and \example
+ \spaceisspace
+ %
+ % Append \endinput to make sure that TeX does not see the ending newline.
+ % I've verified that it is necessary both for e-TeX and for ordinary TeX
+ % --kasal, 29nov03
+ \scantokens{#1\endinput}%
+ \endgroup
+}
+
+\def\scanexp#1{%
+ \edef\temp{\noexpand\scanmacro{#1}}%
+ \temp
+}
+
+\newcount\paramno % Count of parameters
+\newtoks\macname % Macro name
+\newif\ifrecursive % Is it recursive?
+
+% List of all defined macros in the form
+% \definedummyword\macro1\definedummyword\macro2...
+% Currently is also contains all @aliases; the list can be split
+% if there is a need.
+\def\macrolist{}
+
+% Add the macro to \macrolist
+\def\addtomacrolist#1{\expandafter \addtomacrolistxxx \csname#1\endcsname}
+\def\addtomacrolistxxx#1{%
+ \toks0 = \expandafter{\macrolist\definedummyword#1}%
+ \xdef\macrolist{\the\toks0}%
+}
+
+% Utility routines.
+% This does \let #1 = #2, with \csnames; that is,
+% \let \csname#1\endcsname = \csname#2\endcsname
+% (except of course we have to play expansion games).
+%
+\def\cslet#1#2{%
+ \expandafter\let
+ \csname#1\expandafter\endcsname
+ \csname#2\endcsname
+}
+
+% Trim leading and trailing spaces off a string.
+% Concepts from aro-bend problem 15 (see CTAN).
+{\catcode`\@=11
+\gdef\eatspaces #1{\expandafter\trim@\expandafter{#1 }}
+\gdef\trim@ #1{\trim@@ @#1 @ #1 @ @@}
+\gdef\trim@@ #1@ #2@ #3@@{\trim@@@\empty #2 @}
+\def\unbrace#1{#1}
+\unbrace{\gdef\trim@@@ #1 } #2@{#1}
+}
+
+% Trim a single trailing ^^M off a string.
+{\catcode`\^^M=\other \catcode`\Q=3%
+\gdef\eatcr #1{\eatcra #1Q^^MQ}%
+\gdef\eatcra#1^^MQ{\eatcrb#1Q}%
+\gdef\eatcrb#1Q#2Q{#1}%
+}
+
+% Macro bodies are absorbed as an argument in a context where
+% all characters are catcode 10, 11 or 12, except \ which is active
+% (as in normal texinfo). It is necessary to change the definition of \.
+
+% Non-ASCII encodings make 8-bit characters active, so un-activate
+% them to avoid their expansion. Must do this non-globally, to
+% confine the change to the current group.
+
+% It's necessary to have hard CRs when the macro is executed. This is
+% done by making ^^M (\endlinechar) catcode 12 when reading the macro
+% body, and then making it the \newlinechar in \scanmacro.
+
+\def\scanctxt{%
+ \catcode`\"=\other
+ \catcode`\+=\other
+ \catcode`\<=\other
+ \catcode`\>=\other
+ \catcode`\@=\other
+ \catcode`\^=\other
+ \catcode`\_=\other
+ \catcode`\|=\other
+ \catcode`\~=\other
+ \ifx\declaredencoding\ascii \else \setnonasciicharscatcodenonglobal\other \fi
+}
+
+\def\scanargctxt{%
+ \scanctxt
+ \catcode`\\=\other
+ \catcode`\^^M=\other
+}
+
+\def\macrobodyctxt{%
+ \scanctxt
+ \catcode`\{=\other
+ \catcode`\}=\other
+ \catcode`\^^M=\other
+ \usembodybackslash
+}
+
+\def\macroargctxt{%
+ \scanctxt
+ \catcode`\\=\other
+}
+
+% \mbodybackslash is the definition of \ in @macro bodies.
+% It maps \foo\ => \csname macarg.foo\endcsname => #N
+% where N is the macro parameter number.
+% We define \csname macarg.\endcsname to be \realbackslash, so
+% \\ in macro replacement text gets you a backslash.
+
+{\catcode`@=0 @catcode`@\=@active
+ @gdef@usembodybackslash{@let\=@mbodybackslash}
+ @gdef@mbodybackslash#1\{@csname macarg.#1@endcsname}
+}
+\expandafter\def\csname macarg.\endcsname{\realbackslash}
+
+\def\macro{\recursivefalse\parsearg\macroxxx}
+\def\rmacro{\recursivetrue\parsearg\macroxxx}
+
+\def\macroxxx#1{%
+ \getargs{#1}% now \macname is the macname and \argl the arglist
+ \ifx\argl\empty % no arguments
+ \paramno=0%
+ \else
+ \expandafter\parsemargdef \argl;%
+ \fi
+ \if1\csname ismacro.\the\macname\endcsname
+ \message{Warning: redefining \the\macname}%
+ \else
+ \expandafter\ifx\csname \the\macname\endcsname \relax
+ \else \errmessage{Macro name \the\macname\space already defined}\fi
+ \global\cslet{macsave.\the\macname}{\the\macname}%
+ \global\expandafter\let\csname ismacro.\the\macname\endcsname=1%
+ \addtomacrolist{\the\macname}%
+ \fi
+ \begingroup \macrobodyctxt
+ \ifrecursive \expandafter\parsermacbody
+ \else \expandafter\parsemacbody
+ \fi}
+
+\parseargdef\unmacro{%
+ \if1\csname ismacro.#1\endcsname
+ \global\cslet{#1}{macsave.#1}%
+ \global\expandafter\let \csname ismacro.#1\endcsname=0%
+ % Remove the macro name from \macrolist:
+ \begingroup
+ \expandafter\let\csname#1\endcsname \relax
+ \let\definedummyword\unmacrodo
+ \xdef\macrolist{\macrolist}%
+ \endgroup
+ \else
+ \errmessage{Macro #1 not defined}%
+ \fi
+}
+
+% Called by \do from \dounmacro on each macro. The idea is to omit any
+% macro definitions that have been changed to \relax.
+%
+\def\unmacrodo#1{%
+ \ifx #1\relax
+ % remove this
+ \else
+ \noexpand\definedummyword \noexpand#1%
+ \fi
+}
+
+% This makes use of the obscure feature that if the last token of a
+% <parameter list> is #, then the preceding argument is delimited by
+% an opening brace, and that opening brace is not consumed.
+\def\getargs#1{\getargsxxx#1{}}
+\def\getargsxxx#1#{\getmacname #1 \relax\getmacargs}
+\def\getmacname #1 #2\relax{\macname={#1}}
+\def\getmacargs#1{\def\argl{#1}}
+
+% Parse the optional {params} list. Set up \paramno and \paramlist
+% so \defmacro knows what to do. Define \macarg.blah for each blah
+% in the params list, to be ##N where N is the position in that list.
+% That gets used by \mbodybackslash (above).
+
+% We need to get `macro parameter char #' into several definitions.
+% The technique used is stolen from LaTeX: let \hash be something
+% unexpandable, insert that wherever you need a #, and then redefine
+% it to # just before using the token list produced.
+%
+% The same technique is used to protect \eatspaces till just before
+% the macro is used.
+
+\def\parsemargdef#1;{\paramno=0\def\paramlist{}%
+ \let\hash\relax\let\xeatspaces\relax\parsemargdefxxx#1,;,}
+\def\parsemargdefxxx#1,{%
+ \if#1;\let\next=\relax
+ \else \let\next=\parsemargdefxxx
+ \advance\paramno by 1%
+ \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname
+ {\xeatspaces{\hash\the\paramno}}%
+ \edef\paramlist{\paramlist\hash\the\paramno,}%
+ \fi\next}
+
+% These two commands read recursive and nonrecursive macro bodies.
+% (They're different since rec and nonrec macros end differently.)
+
+\long\def\parsemacbody#1@end macro%
+{\xdef\temp{\eatcr{#1}}\endgroup\defmacro}%
+\long\def\parsermacbody#1@end rmacro%
+{\xdef\temp{\eatcr{#1}}\endgroup\defmacro}%
+
+% This defines the macro itself. There are six cases: recursive and
+% nonrecursive macros of zero, one, and many arguments.
+% Much magic with \expandafter here.
+% \xdef is used so that macro definitions will survive the file
+% they're defined in; @include reads the file inside a group.
+\def\defmacro{%
+ \let\hash=##% convert placeholders to macro parameter chars
+ \ifrecursive
+ \ifcase\paramno
+ % 0
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \noexpand\scanmacro{\temp}}%
+ \or % 1
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup\noexpand\macroargctxt
+ \noexpand\braceorline
+ \expandafter\noexpand\csname\the\macname xxx\endcsname}%
+ \expandafter\xdef\csname\the\macname xxx\endcsname##1{%
+ \egroup\noexpand\scanmacro{\temp}}%
+ \else % many
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup\noexpand\macroargctxt
+ \noexpand\csname\the\macname xx\endcsname}%
+ \expandafter\xdef\csname\the\macname xx\endcsname##1{%
+ \expandafter\noexpand\csname\the\macname xxx\endcsname ##1,}%
+ \expandafter\expandafter
+ \expandafter\xdef
+ \expandafter\expandafter
+ \csname\the\macname xxx\endcsname
+ \paramlist{\egroup\noexpand\scanmacro{\temp}}%
+ \fi
+ \else
+ \ifcase\paramno
+ % 0
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \noexpand\norecurse{\the\macname}%
+ \noexpand\scanmacro{\temp}\egroup}%
+ \or % 1
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup\noexpand\macroargctxt
+ \noexpand\braceorline
+ \expandafter\noexpand\csname\the\macname xxx\endcsname}%
+ \expandafter\xdef\csname\the\macname xxx\endcsname##1{%
+ \egroup
+ \noexpand\norecurse{\the\macname}%
+ \noexpand\scanmacro{\temp}\egroup}%
+ \else % many
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup\noexpand\macroargctxt
+ \expandafter\noexpand\csname\the\macname xx\endcsname}%
+ \expandafter\xdef\csname\the\macname xx\endcsname##1{%
+ \expandafter\noexpand\csname\the\macname xxx\endcsname ##1,}%
+ \expandafter\expandafter
+ \expandafter\xdef
+ \expandafter\expandafter
+ \csname\the\macname xxx\endcsname
+ \paramlist{%
+ \egroup
+ \noexpand\norecurse{\the\macname}%
+ \noexpand\scanmacro{\temp}\egroup}%
+ \fi
+ \fi}
+
+\def\norecurse#1{\bgroup\cslet{#1}{macsave.#1}}
+
+% \braceorline decides whether the next nonwhitespace character is a
+% {. If so it reads up to the closing }, if not, it reads the whole
+% line. Whatever was read is then fed to the next control sequence
+% as an argument (by \parsebrace or \parsearg)
+\def\braceorline#1{\let\macnamexxx=#1\futurelet\nchar\braceorlinexxx}
+\def\braceorlinexxx{%
+ \ifx\nchar\bgroup\else
+ \expandafter\parsearg
+ \fi \macnamexxx}
+
+
+% @alias.
+% We need some trickery to remove the optional spaces around the equal
+% sign. Just make them active and then expand them all to nothing.
+\def\alias{\parseargusing\obeyspaces\aliasxxx}
+\def\aliasxxx #1{\aliasyyy#1\relax}
+\def\aliasyyy #1=#2\relax{%
+ {%
+ \expandafter\let\obeyedspace=\empty
+ \addtomacrolist{#1}%
+ \xdef\next{\global\let\makecsname{#1}=\makecsname{#2}}%
+ }%
+ \next
+}
+
+
+\message{cross references,}
+
+\newwrite\auxfile
+\newif\ifhavexrefs % True if xref values are known.
+\newif\ifwarnedxrefs % True if we warned once that they aren't known.
+
+% @inforef is relatively simple.
+\def\inforef #1{\inforefzzz #1,,,,**}
+\def\inforefzzz #1,#2,#3,#4**{\putwordSee{} \putwordInfo{} \putwordfile{} \file{\ignorespaces #3{}},
+ node \samp{\ignorespaces#1{}}}
+
+% @node's only job in TeX is to define \lastnode, which is used in
+% cross-references. The @node line might or might not have commas, and
+% might or might not have spaces before the first comma, like:
+% @node foo , bar , ...
+% We don't want such trailing spaces in the node name.
+%
+\parseargdef\node{\checkenv{}\donode #1 ,\finishnodeparse}
+%
+% also remove a trailing comma, in case of something like this:
+% @node Help-Cross, , , Cross-refs
+\def\donode#1 ,#2\finishnodeparse{\dodonode #1,\finishnodeparse}
+\def\dodonode#1,#2\finishnodeparse{\gdef\lastnode{#1}}
+
+\let\nwnode=\node
+\let\lastnode=\empty
+
+% Write a cross-reference definition for the current node. #1 is the
+% type (Ynumbered, Yappendix, Ynothing).
+%
+\def\donoderef#1{%
+ \ifx\lastnode\empty\else
+ \setref{\lastnode}{#1}%
+ \global\let\lastnode=\empty
+ \fi
+}
+
+% @anchor{NAME} -- define xref target at arbitrary point.
+%
+\newcount\savesfregister
+%
+\def\savesf{\relax \ifhmode \savesfregister=\spacefactor \fi}
+\def\restoresf{\relax \ifhmode \spacefactor=\savesfregister \fi}
+\def\anchor#1{\savesf \setref{#1}{Ynothing}\restoresf \ignorespaces}
+
+% \setref{NAME}{SNT} defines a cross-reference point NAME (a node or an
+% anchor), which consists of three parts:
+% 1) NAME-title - the current sectioning name taken from \lastsection,
+% or the anchor name.
+% 2) NAME-snt - section number and type, passed as the SNT arg, or
+% empty for anchors.
+% 3) NAME-pg - the page number.
+%
+% This is called from \donoderef, \anchor, and \dofloat. In the case of
+% floats, there is an additional part, which is not written here:
+% 4) NAME-lof - the text as it should appear in a @listoffloats.
+%
+\def\setref#1#2{%
+ \pdfmkdest{#1}%
+ \iflinks
+ {%
+ \atdummies % preserve commands, but don't expand them
+ \edef\writexrdef##1##2{%
+ \write\auxfile{@xrdef{#1-% #1 of \setref, expanded by the \edef
+ ##1}{##2}}% these are parameters of \writexrdef
+ }%
+ \toks0 = \expandafter{\lastsection}%
+ \immediate \writexrdef{title}{\the\toks0 }%
+ \immediate \writexrdef{snt}{\csname #2\endcsname}% \Ynumbered etc.
+ \safewhatsit{\writexrdef{pg}{\folio}}% will be written later, during \shipout
+ }%
+ \fi
+}
+
+% @xref, @pxref, and @ref generate cross-references. For \xrefX, #1 is
+% the node name, #2 the name of the Info cross-reference, #3 the printed
+% node name, #4 the name of the Info file, #5 the name of the printed
+% manual. All but the node name can be omitted.
+%
+\def\pxref#1{\putwordsee{} \xrefX[#1,,,,,,,]}
+\def\xref#1{\putwordSee{} \xrefX[#1,,,,,,,]}
+\def\ref#1{\xrefX[#1,,,,,,,]}
+\def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup
+ \unsepspaces
+ \def\printedmanual{\ignorespaces #5}%
+ \def\printedrefname{\ignorespaces #3}%
+ \setbox1=\hbox{\printedmanual\unskip}%
+ \setbox0=\hbox{\printedrefname\unskip}%
+ \ifdim \wd0 = 0pt
+ % No printed node name was explicitly given.
+ \expandafter\ifx\csname SETxref-automatic-section-title\endcsname\relax
+ % Use the node name inside the square brackets.
+ \def\printedrefname{\ignorespaces #1}%
+ \else
+ % Use the actual chapter/section title appear inside
+ % the square brackets. Use the real section title if we have it.
+ \ifdim \wd1 > 0pt
+ % It is in another manual, so we don't have it.
+ \def\printedrefname{\ignorespaces #1}%
+ \else
+ \ifhavexrefs
+ % We know the real title if we have the xref values.
+ \def\printedrefname{\refx{#1-title}{}}%
+ \else
+ % Otherwise just copy the Info node name.
+ \def\printedrefname{\ignorespaces #1}%
+ \fi%
+ \fi
+ \fi
+ \fi
+ %
+ % Make link in pdf output.
+ \ifpdf
+ \leavevmode
+ \getfilename{#4}%
+ {\indexnofonts
+ \turnoffactive
+ % See comments at \activebackslashdouble.
+ {\activebackslashdouble \xdef\pdfxrefdest{#1}%
+ \backslashparens\pdfxrefdest}%
+ %
+ \ifnum\filenamelength>0
+ \startlink attr{/Border [0 0 0]}%
+ goto file{\the\filename.pdf} name{\pdfxrefdest}%
+ \else
+ \startlink attr{/Border [0 0 0]}%
+ goto name{\pdfmkpgn{\pdfxrefdest}}%
+ \fi
+ }%
+ \setcolor{\linkcolor}%
+ \fi
+ %
+ % Float references are printed completely differently: "Figure 1.2"
+ % instead of "[somenode], p.3". We distinguish them by the
+ % LABEL-title being set to a magic string.
+ {%
+ % Have to otherify everything special to allow the \csname to
+ % include an _ in the xref name, etc.
+ \indexnofonts
+ \turnoffactive
+ \expandafter\global\expandafter\let\expandafter\Xthisreftitle
+ \csname XR#1-title\endcsname
+ }%
+ \iffloat\Xthisreftitle
+ % If the user specified the print name (third arg) to the ref,
+ % print it instead of our usual "Figure 1.2".
+ \ifdim\wd0 = 0pt
+ \refx{#1-snt}{}%
+ \else
+ \printedrefname
+ \fi
+ %
+ % if the user also gave the printed manual name (fifth arg), append
+ % "in MANUALNAME".
+ \ifdim \wd1 > 0pt
+ \space \putwordin{} \cite{\printedmanual}%
+ \fi
+ \else
+ % node/anchor (non-float) references.
+ %
+ % If we use \unhbox0 and \unhbox1 to print the node names, TeX does not
+ % insert empty discretionaries after hyphens, which means that it will
+ % not find a line break at a hyphen in a node names. Since some manuals
+ % are best written with fairly long node names, containing hyphens, this
+ % is a loss. Therefore, we give the text of the node name again, so it
+ % is as if TeX is seeing it for the first time.
+ \ifdim \wd1 > 0pt
+ \putwordSection{} ``\printedrefname'' \putwordin{} \cite{\printedmanual}%
+ \else
+ % _ (for example) has to be the character _ for the purposes of the
+ % control sequence corresponding to the node, but it has to expand
+ % into the usual \leavevmode...\vrule stuff for purposes of
+ % printing. So we \turnoffactive for the \refx-snt, back on for the
+ % printing, back off for the \refx-pg.
+ {\turnoffactive
+ % Only output a following space if the -snt ref is nonempty; for
+ % @unnumbered and @anchor, it won't be.
+ \setbox2 = \hbox{\ignorespaces \refx{#1-snt}{}}%
+ \ifdim \wd2 > 0pt \refx{#1-snt}\space\fi
+ }%
+ % output the `[mynode]' via a macro so it can be overridden.
+ \xrefprintnodename\printedrefname
+ %
+ % But we always want a comma and a space:
+ ,\space
+ %
+ % output the `page 3'.
+ \turnoffactive \putwordpage\tie\refx{#1-pg}{}%
+ \fi
+ \fi
+ \endlink
+\endgroup}
+
+% This macro is called from \xrefX for the `[nodename]' part of xref
+% output. It's a separate macro only so it can be changed more easily,
+% since square brackets don't work well in some documents. Particularly
+% one that Bob is working on :).
+%
+\def\xrefprintnodename#1{[#1]}
+
+% Things referred to by \setref.
+%
+\def\Ynothing{}
+\def\Yomitfromtoc{}
+\def\Ynumbered{%
+ \ifnum\secno=0
+ \putwordChapter@tie \the\chapno
+ \else \ifnum\subsecno=0
+ \putwordSection@tie \the\chapno.\the\secno
+ \else \ifnum\subsubsecno=0
+ \putwordSection@tie \the\chapno.\the\secno.\the\subsecno
+ \else
+ \putwordSection@tie \the\chapno.\the\secno.\the\subsecno.\the\subsubsecno
+ \fi\fi\fi
+}
+\def\Yappendix{%
+ \ifnum\secno=0
+ \putwordAppendix@tie @char\the\appendixno{}%
+ \else \ifnum\subsecno=0
+ \putwordSection@tie @char\the\appendixno.\the\secno
+ \else \ifnum\subsubsecno=0
+ \putwordSection@tie @char\the\appendixno.\the\secno.\the\subsecno
+ \else
+ \putwordSection@tie
+ @char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno
+ \fi\fi\fi
+}
+
+% Define \refx{NAME}{SUFFIX} to reference a cross-reference string named NAME.
+% If its value is nonempty, SUFFIX is output afterward.
+%
+\def\refx#1#2{%
+ {%
+ \indexnofonts
+ \otherbackslash
+ \expandafter\global\expandafter\let\expandafter\thisrefX
+ \csname XR#1\endcsname
+ }%
+ \ifx\thisrefX\relax
+ % If not defined, say something at least.
+ \angleleft un\-de\-fined\angleright
+ \iflinks
+ \ifhavexrefs
+ \message{\linenumber Undefined cross reference `#1'.}%
+ \else
+ \ifwarnedxrefs\else
+ \global\warnedxrefstrue
+ \message{Cross reference values unknown; you must run TeX again.}%
+ \fi
+ \fi
+ \fi
+ \else
+ % It's defined, so just use it.
+ \thisrefX
+ \fi
+ #2% Output the suffix in any case.
+}
+
+% This is the macro invoked by entries in the aux file. Usually it's
+% just a \def (we prepend XR to the control sequence name to avoid
+% collisions). But if this is a float type, we have more work to do.
+%
+\def\xrdef#1#2{%
+ {% The node name might contain 8-bit characters, which in our current
+ % implementation are changed to commands like @'e. Don't let these
+ % mess up the control sequence name.
+ \indexnofonts
+ \turnoffactive
+ \xdef\safexrefname{#1}%
+ }%
+ %
+ \expandafter\gdef\csname XR\safexrefname\endcsname{#2}% remember this xref
+ %
+ % Was that xref control sequence that we just defined for a float?
+ \expandafter\iffloat\csname XR\safexrefname\endcsname
+ % it was a float, and we have the (safe) float type in \iffloattype.
+ \expandafter\let\expandafter\floatlist
+ \csname floatlist\iffloattype\endcsname
+ %
+ % Is this the first time we've seen this float type?
+ \expandafter\ifx\floatlist\relax
+ \toks0 = {\do}% yes, so just \do
+ \else
+ % had it before, so preserve previous elements in list.
+ \toks0 = \expandafter{\floatlist\do}%
+ \fi
+ %
+ % Remember this xref in the control sequence \floatlistFLOATTYPE,
+ % for later use in \listoffloats.
+ \expandafter\xdef\csname floatlist\iffloattype\endcsname{\the\toks0
+ {\safexrefname}}%
+ \fi
+}
+
+% Read the last existing aux file, if any. No error if none exists.
+%
+\def\tryauxfile{%
+ \openin 1 \jobname.aux
+ \ifeof 1 \else
+ \readdatafile{aux}%
+ \global\havexrefstrue
+ \fi
+ \closein 1
+}
+
+\def\setupdatafile{%
+ \catcode`\^^@=\other
+ \catcode`\^^A=\other
+ \catcode`\^^B=\other
+ \catcode`\^^C=\other
+ \catcode`\^^D=\other
+ \catcode`\^^E=\other
+ \catcode`\^^F=\other
+ \catcode`\^^G=\other
+ \catcode`\^^H=\other
+ \catcode`\^^K=\other
+ \catcode`\^^L=\other
+ \catcode`\^^N=\other
+ \catcode`\^^P=\other
+ \catcode`\^^Q=\other
+ \catcode`\^^R=\other
+ \catcode`\^^S=\other
+ \catcode`\^^T=\other
+ \catcode`\^^U=\other
+ \catcode`\^^V=\other
+ \catcode`\^^W=\other
+ \catcode`\^^X=\other
+ \catcode`\^^Z=\other
+ \catcode`\^^[=\other
+ \catcode`\^^\=\other
+ \catcode`\^^]=\other
+ \catcode`\^^^=\other
+ \catcode`\^^_=\other
+ % It was suggested to set the catcode of ^ to 7, which would allow ^^e4 etc.
+ % in xref tags, i.e., node names. But since ^^e4 notation isn't
+ % supported in the main text, it doesn't seem desirable. Furthermore,
+ % that is not enough: for node names that actually contain a ^
+ % character, we would end up writing a line like this: 'xrdef {'hat
+ % b-title}{'hat b} and \xrdef does a \csname...\endcsname on the first
+ % argument, and \hat is not an expandable control sequence. It could
+ % all be worked out, but why? Either we support ^^ or we don't.
+ %
+ % The other change necessary for this was to define \auxhat:
+ % \def\auxhat{\def^{'hat }}% extra space so ok if followed by letter
+ % and then to call \auxhat in \setq.
+ %
+ \catcode`\^=\other
+ %
+ % Special characters. Should be turned off anyway, but...
+ \catcode`\~=\other
+ \catcode`\[=\other
+ \catcode`\]=\other
+ \catcode`\"=\other
+ \catcode`\_=\other
+ \catcode`\|=\other
+ \catcode`\<=\other
+ \catcode`\>=\other
+ \catcode`\$=\other
+ \catcode`\#=\other
+ \catcode`\&=\other
+ \catcode`\%=\other
+ \catcode`+=\other % avoid \+ for paranoia even though we've turned it off
+ %
+ % This is to support \ in node names and titles, since the \
+ % characters end up in a \csname. It's easier than
+ % leaving it active and making its active definition an actual \
+ % character. What I don't understand is why it works in the *value*
+ % of the xrdef. Seems like it should be a catcode12 \, and that
+ % should not typeset properly. But it works, so I'm moving on for
+ % now. --karl, 15jan04.
+ \catcode`\\=\other
+ %
+ % Make the characters 128-255 be printing characters.
+ {%
+ \count1=128
+ \def\loop{%
+ \catcode\count1=\other
+ \advance\count1 by 1
+ \ifnum \count1<256 \loop \fi
+ }%
+ }%
+ %
+ % @ is our escape character in .aux files, and we need braces.
+ \catcode`\{=1
+ \catcode`\}=2
+ \catcode`\@=0
+}
+
+\def\readdatafile#1{%
+\begingroup
+ \setupdatafile
+ \input\jobname.#1
+\endgroup}
+
+
+\message{insertions,}
+% including footnotes.
+
+\newcount \footnoteno
+
+% The trailing space in the following definition for supereject is
+% vital for proper filling; pages come out unaligned when you do a
+% pagealignmacro call if that space before the closing brace is
+% removed. (Generally, numeric constants should always be followed by a
+% space to prevent strange expansion errors.)
+\def\supereject{\par\penalty -20000\footnoteno =0 }
+
+% @footnotestyle is meaningful for info output only.
+\let\footnotestyle=\comment
+
+{\catcode `\@=11
+%
+% Auto-number footnotes. Otherwise like plain.
+\gdef\footnote{%
+ \let\indent=\ptexindent
+ \let\noindent=\ptexnoindent
+ \global\advance\footnoteno by \@ne
+ \edef\thisfootno{$^{\the\footnoteno}$}%
+ %
+ % In case the footnote comes at the end of a sentence, preserve the
+ % extra spacing after we do the footnote number.
+ \let\@sf\empty
+ \ifhmode\edef\@sf{\spacefactor\the\spacefactor}\ptexslash\fi
+ %
+ % Remove inadvertent blank space before typesetting the footnote number.
+ \unskip
+ \thisfootno\@sf
+ \dofootnote
+}%
+
+% Don't bother with the trickery in plain.tex to not require the
+% footnote text as a parameter. Our footnotes don't need to be so general.
+%
+% Oh yes, they do; otherwise, @ifset (and anything else that uses
+% \parseargline) fails inside footnotes because the tokens are fixed when
+% the footnote is read. --karl, 16nov96.
+%
+\gdef\dofootnote{%
+ \insert\footins\bgroup
+ % We want to typeset this text as a normal paragraph, even if the
+ % footnote reference occurs in (for example) a display environment.
+ % So reset some parameters.
+ \hsize=\pagewidth
+ \interlinepenalty\interfootnotelinepenalty
+ \splittopskip\ht\strutbox % top baseline for broken footnotes
+ \splitmaxdepth\dp\strutbox
+ \floatingpenalty\@MM
+ \leftskip\z@skip
+ \rightskip\z@skip
+ \spaceskip\z@skip
+ \xspaceskip\z@skip
+ \parindent\defaultparindent
+ %
+ \smallfonts \rm
+ %
+ % Because we use hanging indentation in footnotes, a @noindent appears
+ % to exdent this text, so make it be a no-op. makeinfo does not use
+ % hanging indentation so @noindent can still be needed within footnote
+ % text after an @example or the like (not that this is good style).
+ \let\noindent = \relax
+ %
+ % Hang the footnote text off the number. Use \everypar in case the
+ % footnote extends for more than one paragraph.
+ \everypar = {\hang}%
+ \textindent{\thisfootno}%
+ %
+ % Don't crash into the line above the footnote text. Since this
+ % expands into a box, it must come within the paragraph, lest it
+ % provide a place where TeX can split the footnote.
+ \footstrut
+ \futurelet\next\fo@t
+}
+}%end \catcode `\@=11
+
+% In case a @footnote appears in a vbox, save the footnote text and create
+% the real \insert just after the vbox finished. Otherwise, the insertion
+% would be lost.
+% Similarily, if a @footnote appears inside an alignment, save the footnote
+% text to a box and make the \insert when a row of the table is finished.
+% And the same can be done for other insert classes. --kasal, 16nov03.
+
+% Replace the \insert primitive by a cheating macro.
+% Deeper inside, just make sure that the saved insertions are not spilled
+% out prematurely.
+%
+\def\startsavinginserts{%
+ \ifx \insert\ptexinsert
+ \let\insert\saveinsert
+ \else
+ \let\checkinserts\relax
+ \fi
+}
+
+% This \insert replacement works for both \insert\footins{foo} and
+% \insert\footins\bgroup foo\egroup, but it doesn't work for \insert27{foo}.
+%
+\def\saveinsert#1{%
+ \edef\next{\noexpand\savetobox \makeSAVEname#1}%
+ \afterassignment\next
+ % swallow the left brace
+ \let\temp =
+}
+\def\makeSAVEname#1{\makecsname{SAVE\expandafter\gobble\string#1}}
+\def\savetobox#1{\global\setbox#1 = \vbox\bgroup \unvbox#1}
+
+\def\checksaveins#1{\ifvoid#1\else \placesaveins#1\fi}
+
+\def\placesaveins#1{%
+ \ptexinsert \csname\expandafter\gobblesave\string#1\endcsname
+ {\box#1}%
+}
+
+% eat @SAVE -- beware, all of them have catcode \other:
+{
+ \def\dospecials{\do S\do A\do V\do E} \uncatcodespecials % ;-)
+ \gdef\gobblesave @SAVE{}
+}
+
+% initialization:
+\def\newsaveins #1{%
+ \edef\next{\noexpand\newsaveinsX \makeSAVEname#1}%
+ \next
+}
+\def\newsaveinsX #1{%
+ \csname newbox\endcsname #1%
+ \expandafter\def\expandafter\checkinserts\expandafter{\checkinserts
+ \checksaveins #1}%
+}
+
+% initialize:
+\let\checkinserts\empty
+\newsaveins\footins
+\newsaveins\margin
+
+
+% @image. We use the macros from epsf.tex to support this.
+% If epsf.tex is not installed and @image is used, we complain.
+%
+% Check for and read epsf.tex up front. If we read it only at @image
+% time, we might be inside a group, and then its definitions would get
+% undone and the next image would fail.
+\openin 1 = epsf.tex
+\ifeof 1 \else
+ % Do not bother showing banner with epsf.tex v2.7k (available in
+ % doc/epsf.tex and on ctan).
+ \def\epsfannounce{\toks0 = }%
+ \input epsf.tex
+\fi
+\closein 1
+%
+% We will only complain once about lack of epsf.tex.
+\newif\ifwarnednoepsf
+\newhelp\noepsfhelp{epsf.tex must be installed for images to
+ work. It is also included in the Texinfo distribution, or you can get
+ it from ftp://tug.org/tex/epsf.tex.}
+%
+\def\image#1{%
+ \ifx\epsfbox\undefined
+ \ifwarnednoepsf \else
+ \errhelp = \noepsfhelp
+ \errmessage{epsf.tex not found, images will be ignored}%
+ \global\warnednoepsftrue
+ \fi
+ \else
+ \imagexxx #1,,,,,\finish
+ \fi
+}
+%
+% Arguments to @image:
+% #1 is (mandatory) image filename; we tack on .eps extension.
+% #2 is (optional) width, #3 is (optional) height.
+% #4 is (ignored optional) html alt text.
+% #5 is (ignored optional) extension.
+% #6 is just the usual extra ignored arg for parsing this stuff.
+\newif\ifimagevmode
+\def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup
+ \catcode`\^^M = 5 % in case we're inside an example
+ \normalturnoffactive % allow _ et al. in names
+ % If the image is by itself, center it.
+ \ifvmode
+ \imagevmodetrue
+ \nobreak\bigskip
+ % Usually we'll have text after the image which will insert
+ % \parskip glue, so insert it here too to equalize the space
+ % above and below.
+ \nobreak\vskip\parskip
+ \nobreak
+ \line\bgroup
+ \fi
+ %
+ % Output the image.
+ \ifpdf
+ \dopdfimage{#1}{#2}{#3}%
+ \else
+ % \epsfbox itself resets \epsf?size at each figure.
+ \setbox0 = \hbox{\ignorespaces #2}\ifdim\wd0 > 0pt \epsfxsize=#2\relax \fi
+ \setbox0 = \hbox{\ignorespaces #3}\ifdim\wd0 > 0pt \epsfysize=#3\relax \fi
+ \epsfbox{#1.eps}%
+ \fi
+ %
+ \ifimagevmode \egroup \bigbreak \fi % space after the image
+\endgroup}
+
+
+% @float FLOATTYPE,LABEL,LOC ... @end float for displayed figures, tables,
+% etc. We don't actually implement floating yet, we always include the
+% float "here". But it seemed the best name for the future.
+%
+\envparseargdef\float{\eatcommaspace\eatcommaspace\dofloat#1, , ,\finish}
+
+% There may be a space before second and/or third parameter; delete it.
+\def\eatcommaspace#1, {#1,}
+
+% #1 is the optional FLOATTYPE, the text label for this float, typically
+% "Figure", "Table", "Example", etc. Can't contain commas. If omitted,
+% this float will not be numbered and cannot be referred to.
+%
+% #2 is the optional xref label. Also must be present for the float to
+% be referable.
+%
+% #3 is the optional positioning argument; for now, it is ignored. It
+% will somehow specify the positions allowed to float to (here, top, bottom).
+%
+% We keep a separate counter for each FLOATTYPE, which we reset at each
+% chapter-level command.
+\let\resetallfloatnos=\empty
+%
+\def\dofloat#1,#2,#3,#4\finish{%
+ \let\thiscaption=\empty
+ \let\thisshortcaption=\empty
+ %
+ % don't lose footnotes inside @float.
+ %
+ % BEWARE: when the floats start float, we have to issue warning whenever an
+ % insert appears inside a float which could possibly float. --kasal, 26may04
+ %
+ \startsavinginserts
+ %
+ % We can't be used inside a paragraph.
+ \par
+ %
+ \vtop\bgroup
+ \def\floattype{#1}%
+ \def\floatlabel{#2}%
+ \def\floatloc{#3}% we do nothing with this yet.
+ %
+ \ifx\floattype\empty
+ \let\safefloattype=\empty
+ \else
+ {%
+ % the floattype might have accents or other special characters,
+ % but we need to use it in a control sequence name.
+ \indexnofonts
+ \turnoffactive
+ \xdef\safefloattype{\floattype}%
+ }%
+ \fi
+ %
+ % If label is given but no type, we handle that as the empty type.
+ \ifx\floatlabel\empty \else
+ % We want each FLOATTYPE to be numbered separately (Figure 1,
+ % Table 1, Figure 2, ...). (And if no label, no number.)
+ %
+ \expandafter\getfloatno\csname\safefloattype floatno\endcsname
+ \global\advance\floatno by 1
+ %
+ {%
+ % This magic value for \lastsection is output by \setref as the
+ % XREFLABEL-title value. \xrefX uses it to distinguish float
+ % labels (which have a completely different output format) from
+ % node and anchor labels. And \xrdef uses it to construct the
+ % lists of floats.
+ %
+ \edef\lastsection{\floatmagic=\safefloattype}%
+ \setref{\floatlabel}{Yfloat}%
+ }%
+ \fi
+ %
+ % start with \parskip glue, I guess.
+ \vskip\parskip
+ %
+ % Don't suppress indentation if a float happens to start a section.
+ \restorefirstparagraphindent
+}
+
+% we have these possibilities:
+% @float Foo,lbl & @caption{Cap}: Foo 1.1: Cap
+% @float Foo,lbl & no caption: Foo 1.1
+% @float Foo & @caption{Cap}: Foo: Cap
+% @float Foo & no caption: Foo
+% @float ,lbl & Caption{Cap}: 1.1: Cap
+% @float ,lbl & no caption: 1.1
+% @float & @caption{Cap}: Cap
+% @float & no caption:
+%
+\def\Efloat{%
+ \let\floatident = \empty
+ %
+ % In all cases, if we have a float type, it comes first.
+ \ifx\floattype\empty \else \def\floatident{\floattype}\fi
+ %
+ % If we have an xref label, the number comes next.
+ \ifx\floatlabel\empty \else
+ \ifx\floattype\empty \else % if also had float type, need tie first.
+ \appendtomacro\floatident{\tie}%
+ \fi
+ % the number.
+ \appendtomacro\floatident{\chaplevelprefix\the\floatno}%
+ \fi
+ %
+ % Start the printed caption with what we've constructed in
+ % \floatident, but keep it separate; we need \floatident again.
+ \let\captionline = \floatident
+ %
+ \ifx\thiscaption\empty \else
+ \ifx\floatident\empty \else
+ \appendtomacro\captionline{: }% had ident, so need a colon between
+ \fi
+ %
+ % caption text.
+ \appendtomacro\captionline{\scanexp\thiscaption}%
+ \fi
+ %
+ % If we have anything to print, print it, with space before.
+ % Eventually this needs to become an \insert.
+ \ifx\captionline\empty \else
+ \vskip.5\parskip
+ \captionline
+ %
+ % Space below caption.
+ \vskip\parskip
+ \fi
+ %
+ % If have an xref label, write the list of floats info. Do this
+ % after the caption, to avoid chance of it being a breakpoint.
+ \ifx\floatlabel\empty \else
+ % Write the text that goes in the lof to the aux file as
+ % \floatlabel-lof. Besides \floatident, we include the short
+ % caption if specified, else the full caption if specified, else nothing.
+ {%
+ \atdummies
+ %
+ % since we read the caption text in the macro world, where ^^M
+ % is turned into a normal character, we have to scan it back, so
+ % we don't write the literal three characters "^^M" into the aux file.
+ \scanexp{%
+ \xdef\noexpand\gtemp{%
+ \ifx\thisshortcaption\empty
+ \thiscaption
+ \else
+ \thisshortcaption
+ \fi
+ }%
+ }%
+ \immediate\write\auxfile{@xrdef{\floatlabel-lof}{\floatident
+ \ifx\gtemp\empty \else : \gtemp \fi}}%
+ }%
+ \fi
+ \egroup % end of \vtop
+ %
+ % place the captured inserts
+ %
+ % BEWARE: when the floats start floating, we have to issue warning
+ % whenever an insert appears inside a float which could possibly
+ % float. --kasal, 26may04
+ %
+ \checkinserts
+}
+
+% Append the tokens #2 to the definition of macro #1, not expanding either.
+%
+\def\appendtomacro#1#2{%
+ \expandafter\def\expandafter#1\expandafter{#1#2}%
+}
+
+% @caption, @shortcaption
+%
+\def\caption{\docaption\thiscaption}
+\def\shortcaption{\docaption\thisshortcaption}
+\def\docaption{\checkenv\float \bgroup\scanargctxt\defcaption}
+\def\defcaption#1#2{\egroup \def#1{#2}}
+
+% The parameter is the control sequence identifying the counter we are
+% going to use. Create it if it doesn't exist and assign it to \floatno.
+\def\getfloatno#1{%
+ \ifx#1\relax
+ % Haven't seen this figure type before.
+ \csname newcount\endcsname #1%
+ %
+ % Remember to reset this floatno at the next chap.
+ \expandafter\gdef\expandafter\resetallfloatnos
+ \expandafter{\resetallfloatnos #1=0 }%
+ \fi
+ \let\floatno#1%
+}
+
+% \setref calls this to get the XREFLABEL-snt value. We want an @xref
+% to the FLOATLABEL to expand to "Figure 3.1". We call \setref when we
+% first read the @float command.
+%
+\def\Yfloat{\floattype@tie \chaplevelprefix\the\floatno}%
+
+% Magic string used for the XREFLABEL-title value, so \xrefX can
+% distinguish floats from other xref types.
+\def\floatmagic{!!float!!}
+
+% #1 is the control sequence we are passed; we expand into a conditional
+% which is true if #1 represents a float ref. That is, the magic
+% \lastsection value which we \setref above.
+%
+\def\iffloat#1{\expandafter\doiffloat#1==\finish}
+%
+% #1 is (maybe) the \floatmagic string. If so, #2 will be the
+% (safe) float type for this float. We set \iffloattype to #2.
+%
+\def\doiffloat#1=#2=#3\finish{%
+ \def\temp{#1}%
+ \def\iffloattype{#2}%
+ \ifx\temp\floatmagic
+}
+
+% @listoffloats FLOATTYPE - print a list of floats like a table of contents.
+%
+\parseargdef\listoffloats{%
+ \def\floattype{#1}% floattype
+ {%
+ % the floattype might have accents or other special characters,
+ % but we need to use it in a control sequence name.
+ \indexnofonts
+ \turnoffactive
+ \xdef\safefloattype{\floattype}%
+ }%
+ %
+ % \xrdef saves the floats as a \do-list in \floatlistSAFEFLOATTYPE.
+ \expandafter\ifx\csname floatlist\safefloattype\endcsname \relax
+ \ifhavexrefs
+ % if the user said @listoffloats foo but never @float foo.
+ \message{\linenumber No `\safefloattype' floats to list.}%
+ \fi
+ \else
+ \begingroup
+ \leftskip=\tocindent % indent these entries like a toc
+ \let\do=\listoffloatsdo
+ \csname floatlist\safefloattype\endcsname
+ \endgroup
+ \fi
+}
+
+% This is called on each entry in a list of floats. We're passed the
+% xref label, in the form LABEL-title, which is how we save it in the
+% aux file. We strip off the -title and look up \XRLABEL-lof, which
+% has the text we're supposed to typeset here.
+%
+% Figures without xref labels will not be included in the list (since
+% they won't appear in the aux file).
+%
+\def\listoffloatsdo#1{\listoffloatsdoentry#1\finish}
+\def\listoffloatsdoentry#1-title\finish{{%
+ % Can't fully expand XR#1-lof because it can contain anything. Just
+ % pass the control sequence. On the other hand, XR#1-pg is just the
+ % page number, and we want to fully expand that so we can get a link
+ % in pdf output.
+ \toksA = \expandafter{\csname XR#1-lof\endcsname}%
+ %
+ % use the same \entry macro we use to generate the TOC and index.
+ \edef\writeentry{\noexpand\entry{\the\toksA}{\csname XR#1-pg\endcsname}}%
+ \writeentry
+}}
+
+
+\message{localization,}
+
+% @documentlanguage is usually given very early, just after
+% @setfilename. If done too late, it may not override everything
+% properly. Single argument is the language (de) or locale (de_DE)
+% abbreviation. It would be nice if we could set up a hyphenation file.
+%
+{
+ \catcode`\_ = \active
+ \globaldefs=1
+\parseargdef\documentlanguage{\begingroup
+ \let_=\normalunderscore % normal _ character for filenames
+ \tex % read txi-??.tex file in plain TeX.
+ % Read the file by the name they passed if it exists.
+ \openin 1 txi-#1.tex
+ \ifeof 1
+ \documentlanguagetrywithoutunderscore{#1_\finish}%
+ \else
+ \input txi-#1.tex
+ \fi
+ \closein 1
+ \endgroup
+\endgroup}
+}
+%
+% If they passed de_DE, and txi-de_DE.tex doesn't exist,
+% try txi-de.tex.
+%
+\def\documentlanguagetrywithoutunderscore#1_#2\finish{%
+ \openin 1 txi-#1.tex
+ \ifeof 1
+ \errhelp = \nolanghelp
+ \errmessage{Cannot read language file txi-#1.tex}%
+ \else
+ \input txi-#1.tex
+ \fi
+ \closein 1
+}
+%
+\newhelp\nolanghelp{The given language definition file cannot be found or
+is empty. Maybe you need to install it? In the current directory
+should work if nowhere else does.}
+
+% Set the catcode of characters 128 through 255 to the specified number.
+%
+\def\setnonasciicharscatcode#1{%
+ \count255=128
+ \loop\ifnum\count255<256
+ \global\catcode\count255=#1\relax
+ \advance\count255 by 1
+ \repeat
+}
+
+\def\setnonasciicharscatcodenonglobal#1{%
+ \count255=128
+ \loop\ifnum\count255<256
+ \catcode\count255=#1\relax
+ \advance\count255 by 1
+ \repeat
+}
+
+% @documentencoding sets the definition of non-ASCII characters
+% according to the specified encoding.
+%
+\parseargdef\documentencoding{%
+ % Encoding being declared for the document.
+ \def\declaredencoding{\csname #1.enc\endcsname}%
+ %
+ % Supported encodings: names converted to tokens in order to be able
+ % to compare them with \ifx.
+ \def\ascii{\csname US-ASCII.enc\endcsname}%
+ \def\latnine{\csname ISO-8859-15.enc\endcsname}%
+ \def\latone{\csname ISO-8859-1.enc\endcsname}%
+ \def\lattwo{\csname ISO-8859-2.enc\endcsname}%
+ \def\utfeight{\csname UTF-8.enc\endcsname}%
+ %
+ \ifx \declaredencoding \ascii
+ \asciichardefs
+ %
+ \else \ifx \declaredencoding \lattwo
+ \setnonasciicharscatcode\active
+ \lattwochardefs
+ %
+ \else \ifx \declaredencoding \latone
+ \setnonasciicharscatcode\active
+ \latonechardefs
+ %
+ \else \ifx \declaredencoding \latnine
+ \setnonasciicharscatcode\active
+ \latninechardefs
+ %
+ \else \ifx \declaredencoding \utfeight
+ \setnonasciicharscatcode\active
+ \utfeightchardefs
+ %
+ \else
+ \message{Unknown document encoding #1, ignoring.}%
+ %
+ \fi % utfeight
+ \fi % latnine
+ \fi % latone
+ \fi % lattwo
+ \fi % ascii
+}
+
+% A message to be logged when using a character that isn't available
+% the default font encoding (OT1).
+%
+\def\missingcharmsg#1{\message{Character missing in OT1 encoding: #1.}}
+
+% Take account of \c (plain) vs. \, (Texinfo) difference.
+\def\cedilla#1{\ifx\c\ptexc\c{#1}\else\,{#1}\fi}
+
+% First, make active non-ASCII characters in order for them to be
+% correctly categorized when TeX reads the replacement text of
+% macros containing the character definitions.
+\setnonasciicharscatcode\active
+%
+% Latin1 (ISO-8859-1) character definitions.
+\def\latonechardefs{%
+ \gdef^^a0{~}
+ \gdef^^a1{\exclamdown}
+ \gdef^^a2{\missingcharmsg{CENT SIGN}}
+ \gdef^^a3{{\pounds}}
+ \gdef^^a4{\missingcharmsg{CURRENCY SIGN}}
+ \gdef^^a5{\missingcharmsg{YEN SIGN}}
+ \gdef^^a6{\missingcharmsg{BROKEN BAR}}
+ \gdef^^a7{\S}
+ \gdef^^a8{\"{}}
+ \gdef^^a9{\copyright}
+ \gdef^^aa{\ordf}
+ \gdef^^ab{\missingcharmsg{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}}
+ \gdef^^ac{$\lnot$}
+ \gdef^^ad{\-}
+ \gdef^^ae{\registeredsymbol}
+ \gdef^^af{\={}}
+ %
+ \gdef^^b0{\textdegree}
+ \gdef^^b1{$\pm$}
+ \gdef^^b2{$^2$}
+ \gdef^^b3{$^3$}
+ \gdef^^b4{\'{}}
+ \gdef^^b5{$\mu$}
+ \gdef^^b6{\P}
+ %
+ \gdef^^b7{$^.$}
+ \gdef^^b8{\cedilla\ }
+ \gdef^^b9{$^1$}
+ \gdef^^ba{\ordm}
+ %
+ \gdef^^bb{\missingcharmsg{RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK}}
+ \gdef^^bc{$1\over4$}
+ \gdef^^bd{$1\over2$}
+ \gdef^^be{$3\over4$}
+ \gdef^^bf{\questiondown}
+ %
+ \gdef^^c0{\`A}
+ \gdef^^c1{\'A}
+ \gdef^^c2{\^A}
+ \gdef^^c3{\~A}
+ \gdef^^c4{\"A}
+ \gdef^^c5{\ringaccent A}
+ \gdef^^c6{\AE}
+ \gdef^^c7{\cedilla C}
+ \gdef^^c8{\`E}
+ \gdef^^c9{\'E}
+ \gdef^^ca{\^E}
+ \gdef^^cb{\"E}
+ \gdef^^cc{\`I}
+ \gdef^^cd{\'I}
+ \gdef^^ce{\^I}
+ \gdef^^cf{\"I}
+ %
+ \gdef^^d0{\missingcharmsg{LATIN CAPITAL LETTER ETH}}
+ \gdef^^d1{\~N}
+ \gdef^^d2{\`O}
+ \gdef^^d3{\'O}
+ \gdef^^d4{\^O}
+ \gdef^^d5{\~O}
+ \gdef^^d6{\"O}
+ \gdef^^d7{$\times$}
+ \gdef^^d8{\O}
+ \gdef^^d9{\`U}
+ \gdef^^da{\'U}
+ \gdef^^db{\^U}
+ \gdef^^dc{\"U}
+ \gdef^^dd{\'Y}
+ \gdef^^de{\missingcharmsg{LATIN CAPITAL LETTER THORN}}
+ \gdef^^df{\ss}
+ %
+ \gdef^^e0{\`a}
+ \gdef^^e1{\'a}
+ \gdef^^e2{\^a}
+ \gdef^^e3{\~a}
+ \gdef^^e4{\"a}
+ \gdef^^e5{\ringaccent a}
+ \gdef^^e6{\ae}
+ \gdef^^e7{\cedilla c}
+ \gdef^^e8{\`e}
+ \gdef^^e9{\'e}
+ \gdef^^ea{\^e}
+ \gdef^^eb{\"e}
+ \gdef^^ec{\`{\dotless i}}
+ \gdef^^ed{\'{\dotless i}}
+ \gdef^^ee{\^{\dotless i}}
+ \gdef^^ef{\"{\dotless i}}
+ %
+ \gdef^^f0{\missingcharmsg{LATIN SMALL LETTER ETH}}
+ \gdef^^f1{\~n}
+ \gdef^^f2{\`o}
+ \gdef^^f3{\'o}
+ \gdef^^f4{\^o}
+ \gdef^^f5{\~o}
+ \gdef^^f6{\"o}
+ \gdef^^f7{$\div$}
+ \gdef^^f8{\o}
+ \gdef^^f9{\`u}
+ \gdef^^fa{\'u}
+ \gdef^^fb{\^u}
+ \gdef^^fc{\"u}
+ \gdef^^fd{\'y}
+ \gdef^^fe{\missingcharmsg{LATIN SMALL LETTER THORN}}
+ \gdef^^ff{\"y}
+}
+
+% Latin9 (ISO-8859-15) encoding character definitions.
+\def\latninechardefs{%
+ % Encoding is almost identical to Latin1.
+ \latonechardefs
+ %
+ \gdef^^a4{\euro}
+ \gdef^^a6{\v S}
+ \gdef^^a8{\v s}
+ \gdef^^b4{\v Z}
+ \gdef^^b8{\v z}
+ \gdef^^bc{\OE}
+ \gdef^^bd{\oe}
+ \gdef^^be{\"Y}
+}
+
+% Latin2 (ISO-8859-2) character definitions.
+\def\lattwochardefs{%
+ \gdef^^a0{~}
+ \gdef^^a1{\missingcharmsg{LATIN CAPITAL LETTER A WITH OGONEK}}
+ \gdef^^a2{\u{}}
+ \gdef^^a3{\L}
+ \gdef^^a4{\missingcharmsg{CURRENCY SIGN}}
+ \gdef^^a5{\v L}
+ \gdef^^a6{\'S}
+ \gdef^^a7{\S}
+ \gdef^^a8{\"{}}
+ \gdef^^a9{\v S}
+ \gdef^^aa{\cedilla S}
+ \gdef^^ab{\v T}
+ \gdef^^ac{\'Z}
+ \gdef^^ad{\-}
+ \gdef^^ae{\v Z}
+ \gdef^^af{\dotaccent Z}
+ %
+ \gdef^^b0{\textdegree}
+ \gdef^^b1{\missingcharmsg{LATIN SMALL LETTER A WITH OGONEK}}
+ \gdef^^b2{\missingcharmsg{OGONEK}}
+ \gdef^^b3{\l}
+ \gdef^^b4{\'{}}
+ \gdef^^b5{\v l}
+ \gdef^^b6{\'s}
+ \gdef^^b7{\v{}}
+ \gdef^^b8{\cedilla\ }
+ \gdef^^b9{\v s}
+ \gdef^^ba{\cedilla s}
+ \gdef^^bb{\v t}
+ \gdef^^bc{\'z}
+ \gdef^^bd{\H{}}
+ \gdef^^be{\v z}
+ \gdef^^bf{\dotaccent z}
+ %
+ \gdef^^c0{\'R}
+ \gdef^^c1{\'A}
+ \gdef^^c2{\^A}
+ \gdef^^c3{\u A}
+ \gdef^^c4{\"A}
+ \gdef^^c5{\'L}
+ \gdef^^c6{\'C}
+ \gdef^^c7{\cedilla C}
+ \gdef^^c8{\v C}
+ \gdef^^c9{\'E}
+ \gdef^^ca{\missingcharmsg{LATIN CAPITAL LETTER E WITH OGONEK}}
+ \gdef^^cb{\"E}
+ \gdef^^cc{\v E}
+ \gdef^^cd{\'I}
+ \gdef^^ce{\^I}
+ \gdef^^cf{\v D}
+ %
+ \gdef^^d0{\missingcharmsg{LATIN CAPITAL LETTER D WITH STROKE}}
+ \gdef^^d1{\'N}
+ \gdef^^d2{\v N}
+ \gdef^^d3{\'O}
+ \gdef^^d4{\^O}
+ \gdef^^d5{\H O}
+ \gdef^^d6{\"O}
+ \gdef^^d7{$\times$}
+ \gdef^^d8{\v R}
+ \gdef^^d9{\ringaccent U}
+ \gdef^^da{\'U}
+ \gdef^^db{\H U}
+ \gdef^^dc{\"U}
+ \gdef^^dd{\'Y}
+ \gdef^^de{\cedilla T}
+ \gdef^^df{\ss}
+ %
+ \gdef^^e0{\'r}
+ \gdef^^e1{\'a}
+ \gdef^^e2{\^a}
+ \gdef^^e3{\u a}
+ \gdef^^e4{\"a}
+ \gdef^^e5{\'l}
+ \gdef^^e6{\'c}
+ \gdef^^e7{\cedilla c}
+ \gdef^^e8{\v c}
+ \gdef^^e9{\'e}
+ \gdef^^ea{\missingcharmsg{LATIN SMALL LETTER E WITH OGONEK}}
+ \gdef^^eb{\"e}
+ \gdef^^ec{\v e}
+ \gdef^^ed{\'\i}
+ \gdef^^ee{\^\i}
+ \gdef^^ef{\v d}
+ %
+ \gdef^^f0{\missingcharmsg{LATIN SMALL LETTER D WITH STROKE}}
+ \gdef^^f1{\'n}
+ \gdef^^f2{\v n}
+ \gdef^^f3{\'o}
+ \gdef^^f4{\^o}
+ \gdef^^f5{\H o}
+ \gdef^^f6{\"o}
+ \gdef^^f7{$\div$}
+ \gdef^^f8{\v r}
+ \gdef^^f9{\ringaccent u}
+ \gdef^^fa{\'u}
+ \gdef^^fb{\H u}
+ \gdef^^fc{\"u}
+ \gdef^^fd{\'y}
+ \gdef^^fe{\cedilla t}
+ \gdef^^ff{\dotaccent{}}
+}
+
+% UTF-8 character definitions.
+%
+% This code to support UTF-8 is based on LaTeX's utf8.def, with some
+% changes for Texinfo conventions. It is included here under the GPL by
+% permission from Frank Mittelbach and the LaTeX team.
+%
+\newcount\countUTFx
+\newcount\countUTFy
+\newcount\countUTFz
+
+\gdef\UTFviiiTwoOctets#1#2{\expandafter
+ \UTFviiiDefined\csname u8:#1\string #2\endcsname}
+%
+\gdef\UTFviiiThreeOctets#1#2#3{\expandafter
+ \UTFviiiDefined\csname u8:#1\string #2\string #3\endcsname}
+%
+\gdef\UTFviiiFourOctets#1#2#3#4{\expandafter
+ \UTFviiiDefined\csname u8:#1\string #2\string #3\string #4\endcsname}
+
+\gdef\UTFviiiDefined#1{%
+ \ifx #1\relax
+ \message{\linenumber Unicode char \string #1 not defined for Texinfo}%
+ \else
+ \expandafter #1%
+ \fi
+}
+
+\begingroup
+ \catcode`\~13
+ \catcode`\"12
+
+ \def\UTFviiiLoop{%
+ \global\catcode\countUTFx\active
+ \uccode`\~\countUTFx
+ \uppercase\expandafter{\UTFviiiTmp}%
+ \advance\countUTFx by 1
+ \ifnum\countUTFx < \countUTFy
+ \expandafter\UTFviiiLoop
+ \fi}
+
+ \countUTFx = "C2
+ \countUTFy = "E0
+ \def\UTFviiiTmp{%
+ \xdef~{\noexpand\UTFviiiTwoOctets\string~}}
+ \UTFviiiLoop
+
+ \countUTFx = "E0
+ \countUTFy = "F0
+ \def\UTFviiiTmp{%
+ \xdef~{\noexpand\UTFviiiThreeOctets\string~}}
+ \UTFviiiLoop
+
+ \countUTFx = "F0
+ \countUTFy = "F4
+ \def\UTFviiiTmp{%
+ \xdef~{\noexpand\UTFviiiFourOctets\string~}}
+ \UTFviiiLoop
+\endgroup
+
+\begingroup
+ \catcode`\"=12
+ \catcode`\<=12
+ \catcode`\.=12
+ \catcode`\,=12
+ \catcode`\;=12
+ \catcode`\!=12
+ \catcode`\~=13
+
+ \gdef\DeclareUnicodeCharacter#1#2{%
+ \countUTFz = "#1\relax
+ \wlog{\space\space defining Unicode char U+#1 (decimal \the\countUTFz)}%
+ \begingroup
+ \parseXMLCharref
+ \def\UTFviiiTwoOctets##1##2{%
+ \csname u8:##1\string ##2\endcsname}%
+ \def\UTFviiiThreeOctets##1##2##3{%
+ \csname u8:##1\string ##2\string ##3\endcsname}%
+ \def\UTFviiiFourOctets##1##2##3##4{%
+ \csname u8:##1\string ##2\string ##3\string ##4\endcsname}%
+ \expandafter\expandafter\expandafter\expandafter
+ \expandafter\expandafter\expandafter
+ \gdef\UTFviiiTmp{#2}%
+ \endgroup}
+
+ \gdef\parseXMLCharref{%
+ \ifnum\countUTFz < "A0\relax
+ \errhelp = \EMsimple
+ \errmessage{Cannot define Unicode char value < 00A0}%
+ \else\ifnum\countUTFz < "800\relax
+ \parseUTFviiiA,%
+ \parseUTFviiiB C\UTFviiiTwoOctets.,%
+ \else\ifnum\countUTFz < "10000\relax
+ \parseUTFviiiA;%
+ \parseUTFviiiA,%
+ \parseUTFviiiB E\UTFviiiThreeOctets.{,;}%
+ \else
+ \parseUTFviiiA;%
+ \parseUTFviiiA,%
+ \parseUTFviiiA!%
+ \parseUTFviiiB F\UTFviiiFourOctets.{!,;}%
+ \fi\fi\fi
+ }
+
+ \gdef\parseUTFviiiA#1{%
+ \countUTFx = \countUTFz
+ \divide\countUTFz by 64
+ \countUTFy = \countUTFz
+ \multiply\countUTFz by 64
+ \advance\countUTFx by -\countUTFz
+ \advance\countUTFx by 128
+ \uccode `#1\countUTFx
+ \countUTFz = \countUTFy}
+
+ \gdef\parseUTFviiiB#1#2#3#4{%
+ \advance\countUTFz by "#10\relax
+ \uccode `#3\countUTFz
+ \uppercase{\gdef\UTFviiiTmp{#2#3#4}}}
+\endgroup
+
+\def\utfeightchardefs{%
+ \DeclareUnicodeCharacter{00A0}{\tie}
+ \DeclareUnicodeCharacter{00A1}{\exclamdown}
+ \DeclareUnicodeCharacter{00A3}{\pounds}
+ \DeclareUnicodeCharacter{00A8}{\"{ }}
+ \DeclareUnicodeCharacter{00A9}{\copyright}
+ \DeclareUnicodeCharacter{00AA}{\ordf}
+ \DeclareUnicodeCharacter{00AB}{\guillemetleft}
+ \DeclareUnicodeCharacter{00AD}{\-}
+ \DeclareUnicodeCharacter{00AE}{\registeredsymbol}
+ \DeclareUnicodeCharacter{00AF}{\={ }}
+
+ \DeclareUnicodeCharacter{00B0}{\ringaccent{ }}
+ \DeclareUnicodeCharacter{00B4}{\'{ }}
+ \DeclareUnicodeCharacter{00B8}{\cedilla{ }}
+ \DeclareUnicodeCharacter{00BA}{\ordm}
+ \DeclareUnicodeCharacter{00BB}{\guillemetright}
+ \DeclareUnicodeCharacter{00BF}{\questiondown}
+
+ \DeclareUnicodeCharacter{00C0}{\`A}
+ \DeclareUnicodeCharacter{00C1}{\'A}
+ \DeclareUnicodeCharacter{00C2}{\^A}
+ \DeclareUnicodeCharacter{00C3}{\~A}
+ \DeclareUnicodeCharacter{00C4}{\"A}
+ \DeclareUnicodeCharacter{00C5}{\AA}
+ \DeclareUnicodeCharacter{00C6}{\AE}
+ \DeclareUnicodeCharacter{00C7}{\cedilla{C}}
+ \DeclareUnicodeCharacter{00C8}{\`E}
+ \DeclareUnicodeCharacter{00C9}{\'E}
+ \DeclareUnicodeCharacter{00CA}{\^E}
+ \DeclareUnicodeCharacter{00CB}{\"E}
+ \DeclareUnicodeCharacter{00CC}{\`I}
+ \DeclareUnicodeCharacter{00CD}{\'I}
+ \DeclareUnicodeCharacter{00CE}{\^I}
+ \DeclareUnicodeCharacter{00CF}{\"I}
+
+ \DeclareUnicodeCharacter{00D1}{\~N}
+ \DeclareUnicodeCharacter{00D2}{\`O}
+ \DeclareUnicodeCharacter{00D3}{\'O}
+ \DeclareUnicodeCharacter{00D4}{\^O}
+ \DeclareUnicodeCharacter{00D5}{\~O}
+ \DeclareUnicodeCharacter{00D6}{\"O}
+ \DeclareUnicodeCharacter{00D8}{\O}
+ \DeclareUnicodeCharacter{00D9}{\`U}
+ \DeclareUnicodeCharacter{00DA}{\'U}
+ \DeclareUnicodeCharacter{00DB}{\^U}
+ \DeclareUnicodeCharacter{00DC}{\"U}
+ \DeclareUnicodeCharacter{00DD}{\'Y}
+ \DeclareUnicodeCharacter{00DF}{\ss}
+
+ \DeclareUnicodeCharacter{00E0}{\`a}
+ \DeclareUnicodeCharacter{00E1}{\'a}
+ \DeclareUnicodeCharacter{00E2}{\^a}
+ \DeclareUnicodeCharacter{00E3}{\~a}
+ \DeclareUnicodeCharacter{00E4}{\"a}
+ \DeclareUnicodeCharacter{00E5}{\aa}
+ \DeclareUnicodeCharacter{00E6}{\ae}
+ \DeclareUnicodeCharacter{00E7}{\cedilla{c}}
+ \DeclareUnicodeCharacter{00E8}{\`e}
+ \DeclareUnicodeCharacter{00E9}{\'e}
+ \DeclareUnicodeCharacter{00EA}{\^e}
+ \DeclareUnicodeCharacter{00EB}{\"e}
+ \DeclareUnicodeCharacter{00EC}{\`{\dotless{i}}}
+ \DeclareUnicodeCharacter{00ED}{\'{\dotless{i}}}
+ \DeclareUnicodeCharacter{00EE}{\^{\dotless{i}}}
+ \DeclareUnicodeCharacter{00EF}{\"{\dotless{i}}}
+
+ \DeclareUnicodeCharacter{00F1}{\~n}
+ \DeclareUnicodeCharacter{00F2}{\`o}
+ \DeclareUnicodeCharacter{00F3}{\'o}
+ \DeclareUnicodeCharacter{00F4}{\^o}
+ \DeclareUnicodeCharacter{00F5}{\~o}
+ \DeclareUnicodeCharacter{00F6}{\"o}
+ \DeclareUnicodeCharacter{00F8}{\o}
+ \DeclareUnicodeCharacter{00F9}{\`u}
+ \DeclareUnicodeCharacter{00FA}{\'u}
+ \DeclareUnicodeCharacter{00FB}{\^u}
+ \DeclareUnicodeCharacter{00FC}{\"u}
+ \DeclareUnicodeCharacter{00FD}{\'y}
+ \DeclareUnicodeCharacter{00FF}{\"y}
+
+ \DeclareUnicodeCharacter{0100}{\=A}
+ \DeclareUnicodeCharacter{0101}{\=a}
+ \DeclareUnicodeCharacter{0102}{\u{A}}
+ \DeclareUnicodeCharacter{0103}{\u{a}}
+ \DeclareUnicodeCharacter{0106}{\'C}
+ \DeclareUnicodeCharacter{0107}{\'c}
+ \DeclareUnicodeCharacter{0108}{\^C}
+ \DeclareUnicodeCharacter{0109}{\^c}
+ \DeclareUnicodeCharacter{010A}{\dotaccent{C}}
+ \DeclareUnicodeCharacter{010B}{\dotaccent{c}}
+ \DeclareUnicodeCharacter{010C}{\v{C}}
+ \DeclareUnicodeCharacter{010D}{\v{c}}
+ \DeclareUnicodeCharacter{010E}{\v{D}}
+
+ \DeclareUnicodeCharacter{0112}{\=E}
+ \DeclareUnicodeCharacter{0113}{\=e}
+ \DeclareUnicodeCharacter{0114}{\u{E}}
+ \DeclareUnicodeCharacter{0115}{\u{e}}
+ \DeclareUnicodeCharacter{0116}{\dotaccent{E}}
+ \DeclareUnicodeCharacter{0117}{\dotaccent{e}}
+ \DeclareUnicodeCharacter{011A}{\v{E}}
+ \DeclareUnicodeCharacter{011B}{\v{e}}
+ \DeclareUnicodeCharacter{011C}{\^G}
+ \DeclareUnicodeCharacter{011D}{\^g}
+ \DeclareUnicodeCharacter{011E}{\u{G}}
+ \DeclareUnicodeCharacter{011F}{\u{g}}
+
+ \DeclareUnicodeCharacter{0120}{\dotaccent{G}}
+ \DeclareUnicodeCharacter{0121}{\dotaccent{g}}
+ \DeclareUnicodeCharacter{0124}{\^H}
+ \DeclareUnicodeCharacter{0125}{\^h}
+ \DeclareUnicodeCharacter{0128}{\~I}
+ \DeclareUnicodeCharacter{0129}{\~{\dotless{i}}}
+ \DeclareUnicodeCharacter{012A}{\=I}
+ \DeclareUnicodeCharacter{012B}{\={\dotless{i}}}
+ \DeclareUnicodeCharacter{012C}{\u{I}}
+ \DeclareUnicodeCharacter{012D}{\u{\dotless{i}}}
+
+ \DeclareUnicodeCharacter{0130}{\dotaccent{I}}
+ \DeclareUnicodeCharacter{0131}{\dotless{i}}
+ \DeclareUnicodeCharacter{0132}{IJ}
+ \DeclareUnicodeCharacter{0133}{ij}
+ \DeclareUnicodeCharacter{0134}{\^J}
+ \DeclareUnicodeCharacter{0135}{\^{\dotless{j}}}
+ \DeclareUnicodeCharacter{0139}{\'L}
+ \DeclareUnicodeCharacter{013A}{\'l}
+
+ \DeclareUnicodeCharacter{0141}{\L}
+ \DeclareUnicodeCharacter{0142}{\l}
+ \DeclareUnicodeCharacter{0143}{\'N}
+ \DeclareUnicodeCharacter{0144}{\'n}
+ \DeclareUnicodeCharacter{0147}{\v{N}}
+ \DeclareUnicodeCharacter{0148}{\v{n}}
+ \DeclareUnicodeCharacter{014C}{\=O}
+ \DeclareUnicodeCharacter{014D}{\=o}
+ \DeclareUnicodeCharacter{014E}{\u{O}}
+ \DeclareUnicodeCharacter{014F}{\u{o}}
+
+ \DeclareUnicodeCharacter{0150}{\H{O}}
+ \DeclareUnicodeCharacter{0151}{\H{o}}
+ \DeclareUnicodeCharacter{0152}{\OE}
+ \DeclareUnicodeCharacter{0153}{\oe}
+ \DeclareUnicodeCharacter{0154}{\'R}
+ \DeclareUnicodeCharacter{0155}{\'r}
+ \DeclareUnicodeCharacter{0158}{\v{R}}
+ \DeclareUnicodeCharacter{0159}{\v{r}}
+ \DeclareUnicodeCharacter{015A}{\'S}
+ \DeclareUnicodeCharacter{015B}{\'s}
+ \DeclareUnicodeCharacter{015C}{\^S}
+ \DeclareUnicodeCharacter{015D}{\^s}
+ \DeclareUnicodeCharacter{015E}{\cedilla{S}}
+ \DeclareUnicodeCharacter{015F}{\cedilla{s}}
+
+ \DeclareUnicodeCharacter{0160}{\v{S}}
+ \DeclareUnicodeCharacter{0161}{\v{s}}
+ \DeclareUnicodeCharacter{0162}{\cedilla{t}}
+ \DeclareUnicodeCharacter{0163}{\cedilla{T}}
+ \DeclareUnicodeCharacter{0164}{\v{T}}
+
+ \DeclareUnicodeCharacter{0168}{\~U}
+ \DeclareUnicodeCharacter{0169}{\~u}
+ \DeclareUnicodeCharacter{016A}{\=U}
+ \DeclareUnicodeCharacter{016B}{\=u}
+ \DeclareUnicodeCharacter{016C}{\u{U}}
+ \DeclareUnicodeCharacter{016D}{\u{u}}
+ \DeclareUnicodeCharacter{016E}{\ringaccent{U}}
+ \DeclareUnicodeCharacter{016F}{\ringaccent{u}}
+
+ \DeclareUnicodeCharacter{0170}{\H{U}}
+ \DeclareUnicodeCharacter{0171}{\H{u}}
+ \DeclareUnicodeCharacter{0174}{\^W}
+ \DeclareUnicodeCharacter{0175}{\^w}
+ \DeclareUnicodeCharacter{0176}{\^Y}
+ \DeclareUnicodeCharacter{0177}{\^y}
+ \DeclareUnicodeCharacter{0178}{\"Y}
+ \DeclareUnicodeCharacter{0179}{\'Z}
+ \DeclareUnicodeCharacter{017A}{\'z}
+ \DeclareUnicodeCharacter{017B}{\dotaccent{Z}}
+ \DeclareUnicodeCharacter{017C}{\dotaccent{z}}
+ \DeclareUnicodeCharacter{017D}{\v{Z}}
+ \DeclareUnicodeCharacter{017E}{\v{z}}
+
+ \DeclareUnicodeCharacter{01C4}{D\v{Z}}
+ \DeclareUnicodeCharacter{01C5}{D\v{z}}
+ \DeclareUnicodeCharacter{01C6}{d\v{z}}
+ \DeclareUnicodeCharacter{01C7}{LJ}
+ \DeclareUnicodeCharacter{01C8}{Lj}
+ \DeclareUnicodeCharacter{01C9}{lj}
+ \DeclareUnicodeCharacter{01CA}{NJ}
+ \DeclareUnicodeCharacter{01CB}{Nj}
+ \DeclareUnicodeCharacter{01CC}{nj}
+ \DeclareUnicodeCharacter{01CD}{\v{A}}
+ \DeclareUnicodeCharacter{01CE}{\v{a}}
+ \DeclareUnicodeCharacter{01CF}{\v{I}}
+
+ \DeclareUnicodeCharacter{01D0}{\v{\dotless{i}}}
+ \DeclareUnicodeCharacter{01D1}{\v{O}}
+ \DeclareUnicodeCharacter{01D2}{\v{o}}
+ \DeclareUnicodeCharacter{01D3}{\v{U}}
+ \DeclareUnicodeCharacter{01D4}{\v{u}}
+
+ \DeclareUnicodeCharacter{01E2}{\={\AE}}
+ \DeclareUnicodeCharacter{01E3}{\={\ae}}
+ \DeclareUnicodeCharacter{01E6}{\v{G}}
+ \DeclareUnicodeCharacter{01E7}{\v{g}}
+ \DeclareUnicodeCharacter{01E8}{\v{K}}
+ \DeclareUnicodeCharacter{01E9}{\v{k}}
+
+ \DeclareUnicodeCharacter{01F0}{\v{\dotless{j}}}
+ \DeclareUnicodeCharacter{01F1}{DZ}
+ \DeclareUnicodeCharacter{01F2}{Dz}
+ \DeclareUnicodeCharacter{01F3}{dz}
+ \DeclareUnicodeCharacter{01F4}{\'G}
+ \DeclareUnicodeCharacter{01F5}{\'g}
+ \DeclareUnicodeCharacter{01F8}{\`N}
+ \DeclareUnicodeCharacter{01F9}{\`n}
+ \DeclareUnicodeCharacter{01FC}{\'{\AE}}
+ \DeclareUnicodeCharacter{01FD}{\'{\ae}}
+ \DeclareUnicodeCharacter{01FE}{\'{\O}}
+ \DeclareUnicodeCharacter{01FF}{\'{\o}}
+
+ \DeclareUnicodeCharacter{021E}{\v{H}}
+ \DeclareUnicodeCharacter{021F}{\v{h}}
+
+ \DeclareUnicodeCharacter{0226}{\dotaccent{A}}
+ \DeclareUnicodeCharacter{0227}{\dotaccent{a}}
+ \DeclareUnicodeCharacter{0228}{\cedilla{E}}
+ \DeclareUnicodeCharacter{0229}{\cedilla{e}}
+ \DeclareUnicodeCharacter{022E}{\dotaccent{O}}
+ \DeclareUnicodeCharacter{022F}{\dotaccent{o}}
+
+ \DeclareUnicodeCharacter{0232}{\=Y}
+ \DeclareUnicodeCharacter{0233}{\=y}
+ \DeclareUnicodeCharacter{0237}{\dotless{j}}
+
+ \DeclareUnicodeCharacter{1E02}{\dotaccent{B}}
+ \DeclareUnicodeCharacter{1E03}{\dotaccent{b}}
+ \DeclareUnicodeCharacter{1E04}{\udotaccent{B}}
+ \DeclareUnicodeCharacter{1E05}{\udotaccent{b}}
+ \DeclareUnicodeCharacter{1E06}{\ubaraccent{B}}
+ \DeclareUnicodeCharacter{1E07}{\ubaraccent{b}}
+ \DeclareUnicodeCharacter{1E0A}{\dotaccent{D}}
+ \DeclareUnicodeCharacter{1E0B}{\dotaccent{d}}
+ \DeclareUnicodeCharacter{1E0C}{\udotaccent{D}}
+ \DeclareUnicodeCharacter{1E0D}{\udotaccent{d}}
+ \DeclareUnicodeCharacter{1E0E}{\ubaraccent{D}}
+ \DeclareUnicodeCharacter{1E0F}{\ubaraccent{d}}
+
+ \DeclareUnicodeCharacter{1E1E}{\dotaccent{F}}
+ \DeclareUnicodeCharacter{1E1F}{\dotaccent{f}}
+
+ \DeclareUnicodeCharacter{1E20}{\=G}
+ \DeclareUnicodeCharacter{1E21}{\=g}
+ \DeclareUnicodeCharacter{1E22}{\dotaccent{H}}
+ \DeclareUnicodeCharacter{1E23}{\dotaccent{h}}
+ \DeclareUnicodeCharacter{1E24}{\udotaccent{H}}
+ \DeclareUnicodeCharacter{1E25}{\udotaccent{h}}
+ \DeclareUnicodeCharacter{1E26}{\"H}
+ \DeclareUnicodeCharacter{1E27}{\"h}
+
+ \DeclareUnicodeCharacter{1E30}{\'K}
+ \DeclareUnicodeCharacter{1E31}{\'k}
+ \DeclareUnicodeCharacter{1E32}{\udotaccent{K}}
+ \DeclareUnicodeCharacter{1E33}{\udotaccent{k}}
+ \DeclareUnicodeCharacter{1E34}{\ubaraccent{K}}
+ \DeclareUnicodeCharacter{1E35}{\ubaraccent{k}}
+ \DeclareUnicodeCharacter{1E36}{\udotaccent{L}}
+ \DeclareUnicodeCharacter{1E37}{\udotaccent{l}}
+ \DeclareUnicodeCharacter{1E3A}{\ubaraccent{L}}
+ \DeclareUnicodeCharacter{1E3B}{\ubaraccent{l}}
+ \DeclareUnicodeCharacter{1E3E}{\'M}
+ \DeclareUnicodeCharacter{1E3F}{\'m}
+
+ \DeclareUnicodeCharacter{1E40}{\dotaccent{M}}
+ \DeclareUnicodeCharacter{1E41}{\dotaccent{m}}
+ \DeclareUnicodeCharacter{1E42}{\udotaccent{M}}
+ \DeclareUnicodeCharacter{1E43}{\udotaccent{m}}
+ \DeclareUnicodeCharacter{1E44}{\dotaccent{N}}
+ \DeclareUnicodeCharacter{1E45}{\dotaccent{n}}
+ \DeclareUnicodeCharacter{1E46}{\udotaccent{N}}
+ \DeclareUnicodeCharacter{1E47}{\udotaccent{n}}
+ \DeclareUnicodeCharacter{1E48}{\ubaraccent{N}}
+ \DeclareUnicodeCharacter{1E49}{\ubaraccent{n}}
+
+ \DeclareUnicodeCharacter{1E54}{\'P}
+ \DeclareUnicodeCharacter{1E55}{\'p}
+ \DeclareUnicodeCharacter{1E56}{\dotaccent{P}}
+ \DeclareUnicodeCharacter{1E57}{\dotaccent{p}}
+ \DeclareUnicodeCharacter{1E58}{\dotaccent{R}}
+ \DeclareUnicodeCharacter{1E59}{\dotaccent{r}}
+ \DeclareUnicodeCharacter{1E5A}{\udotaccent{R}}
+ \DeclareUnicodeCharacter{1E5B}{\udotaccent{r}}
+ \DeclareUnicodeCharacter{1E5E}{\ubaraccent{R}}
+ \DeclareUnicodeCharacter{1E5F}{\ubaraccent{r}}
+
+ \DeclareUnicodeCharacter{1E60}{\dotaccent{S}}
+ \DeclareUnicodeCharacter{1E61}{\dotaccent{s}}
+ \DeclareUnicodeCharacter{1E62}{\udotaccent{S}}
+ \DeclareUnicodeCharacter{1E63}{\udotaccent{s}}
+ \DeclareUnicodeCharacter{1E6A}{\dotaccent{T}}
+ \DeclareUnicodeCharacter{1E6B}{\dotaccent{t}}
+ \DeclareUnicodeCharacter{1E6C}{\udotaccent{T}}
+ \DeclareUnicodeCharacter{1E6D}{\udotaccent{t}}
+ \DeclareUnicodeCharacter{1E6E}{\ubaraccent{T}}
+ \DeclareUnicodeCharacter{1E6F}{\ubaraccent{t}}
+
+ \DeclareUnicodeCharacter{1E7C}{\~V}
+ \DeclareUnicodeCharacter{1E7D}{\~v}
+ \DeclareUnicodeCharacter{1E7E}{\udotaccent{V}}
+ \DeclareUnicodeCharacter{1E7F}{\udotaccent{v}}
+
+ \DeclareUnicodeCharacter{1E80}{\`W}
+ \DeclareUnicodeCharacter{1E81}{\`w}
+ \DeclareUnicodeCharacter{1E82}{\'W}
+ \DeclareUnicodeCharacter{1E83}{\'w}
+ \DeclareUnicodeCharacter{1E84}{\"W}
+ \DeclareUnicodeCharacter{1E85}{\"w}
+ \DeclareUnicodeCharacter{1E86}{\dotaccent{W}}
+ \DeclareUnicodeCharacter{1E87}{\dotaccent{w}}
+ \DeclareUnicodeCharacter{1E88}{\udotaccent{W}}
+ \DeclareUnicodeCharacter{1E89}{\udotaccent{w}}
+ \DeclareUnicodeCharacter{1E8A}{\dotaccent{X}}
+ \DeclareUnicodeCharacter{1E8B}{\dotaccent{x}}
+ \DeclareUnicodeCharacter{1E8C}{\"X}
+ \DeclareUnicodeCharacter{1E8D}{\"x}
+ \DeclareUnicodeCharacter{1E8E}{\dotaccent{Y}}
+ \DeclareUnicodeCharacter{1E8F}{\dotaccent{y}}
+
+ \DeclareUnicodeCharacter{1E90}{\^Z}
+ \DeclareUnicodeCharacter{1E91}{\^z}
+ \DeclareUnicodeCharacter{1E92}{\udotaccent{Z}}
+ \DeclareUnicodeCharacter{1E93}{\udotaccent{z}}
+ \DeclareUnicodeCharacter{1E94}{\ubaraccent{Z}}
+ \DeclareUnicodeCharacter{1E95}{\ubaraccent{z}}
+ \DeclareUnicodeCharacter{1E96}{\ubaraccent{h}}
+ \DeclareUnicodeCharacter{1E97}{\"t}
+ \DeclareUnicodeCharacter{1E98}{\ringaccent{w}}
+ \DeclareUnicodeCharacter{1E99}{\ringaccent{y}}
+
+ \DeclareUnicodeCharacter{1EA0}{\udotaccent{A}}
+ \DeclareUnicodeCharacter{1EA1}{\udotaccent{a}}
+
+ \DeclareUnicodeCharacter{1EB8}{\udotaccent{E}}
+ \DeclareUnicodeCharacter{1EB9}{\udotaccent{e}}
+ \DeclareUnicodeCharacter{1EBC}{\~E}
+ \DeclareUnicodeCharacter{1EBD}{\~e}
+
+ \DeclareUnicodeCharacter{1ECA}{\udotaccent{I}}
+ \DeclareUnicodeCharacter{1ECB}{\udotaccent{i}}
+ \DeclareUnicodeCharacter{1ECC}{\udotaccent{O}}
+ \DeclareUnicodeCharacter{1ECD}{\udotaccent{o}}
+
+ \DeclareUnicodeCharacter{1EE4}{\udotaccent{U}}
+ \DeclareUnicodeCharacter{1EE5}{\udotaccent{u}}
+
+ \DeclareUnicodeCharacter{1EF2}{\`Y}
+ \DeclareUnicodeCharacter{1EF3}{\`y}
+ \DeclareUnicodeCharacter{1EF4}{\udotaccent{Y}}
+
+ \DeclareUnicodeCharacter{1EF8}{\~Y}
+ \DeclareUnicodeCharacter{1EF9}{\~y}
+
+ \DeclareUnicodeCharacter{2013}{--}
+ \DeclareUnicodeCharacter{2014}{---}
+ \DeclareUnicodeCharacter{2018}{\quoteleft}
+ \DeclareUnicodeCharacter{2019}{\quoteright}
+ \DeclareUnicodeCharacter{201A}{\quotesinglbase}
+ \DeclareUnicodeCharacter{201C}{\quotedblleft}
+ \DeclareUnicodeCharacter{201D}{\quotedblright}
+ \DeclareUnicodeCharacter{201E}{\quotedblbase}
+ \DeclareUnicodeCharacter{2022}{\bullet}
+ \DeclareUnicodeCharacter{2026}{\dots}
+ \DeclareUnicodeCharacter{2039}{\guilsinglleft}
+ \DeclareUnicodeCharacter{203A}{\guilsinglright}
+ \DeclareUnicodeCharacter{20AC}{\euro}
+
+ \DeclareUnicodeCharacter{2192}{\expansion}
+ \DeclareUnicodeCharacter{21D2}{\result}
+
+ \DeclareUnicodeCharacter{2212}{\minus}
+ \DeclareUnicodeCharacter{2217}{\point}
+ \DeclareUnicodeCharacter{2261}{\equiv}
+}% end of \utfeightchardefs
+
+
+% US-ASCII character definitions.
+\def\asciichardefs{% nothing need be done
+ \relax
+}
+
+% Make non-ASCII characters printable again for compatibility with
+% existing Texinfo documents that may use them, even without declaring a
+% document encoding.
+%
+\setnonasciicharscatcode \other
+
+
+\message{formatting,}
+
+\newdimen\defaultparindent \defaultparindent = 15pt
+
+\chapheadingskip = 15pt plus 4pt minus 2pt
+\secheadingskip = 12pt plus 3pt minus 2pt
+\subsecheadingskip = 9pt plus 2pt minus 2pt
+
+% Prevent underfull vbox error messages.
+\vbadness = 10000
+
+% Don't be so finicky about underfull hboxes, either.
+\hbadness = 2000
+
+% Following George Bush, get rid of widows and orphans.
+\widowpenalty=10000
+\clubpenalty=10000
+
+% Use TeX 3.0's \emergencystretch to help line breaking, but if we're
+% using an old version of TeX, don't do anything. We want the amount of
+% stretch added to depend on the line length, hence the dependence on
+% \hsize. We call this whenever the paper size is set.
+%
+\def\setemergencystretch{%
+ \ifx\emergencystretch\thisisundefined
+ % Allow us to assign to \emergencystretch anyway.
+ \def\emergencystretch{\dimen0}%
+ \else
+ \emergencystretch = .15\hsize
+ \fi
+}
+
+% Parameters in order: 1) textheight; 2) textwidth;
+% 3) voffset; 4) hoffset; 5) binding offset; 6) topskip;
+% 7) physical page height; 8) physical page width.
+%
+% We also call \setleading{\textleading}, so the caller should define
+% \textleading. The caller should also set \parskip.
+%
+\def\internalpagesizes#1#2#3#4#5#6#7#8{%
+ \voffset = #3\relax
+ \topskip = #6\relax
+ \splittopskip = \topskip
+ %
+ \vsize = #1\relax
+ \advance\vsize by \topskip
+ \outervsize = \vsize
+ \advance\outervsize by 2\topandbottommargin
+ \pageheight = \vsize
+ %
+ \hsize = #2\relax
+ \outerhsize = \hsize
+ \advance\outerhsize by 0.5in
+ \pagewidth = \hsize
+ %
+ \normaloffset = #4\relax
+ \bindingoffset = #5\relax
+ %
+ \ifpdf
+ \pdfpageheight #7\relax
+ \pdfpagewidth #8\relax
+ % if we don't reset these, they will remain at "1 true in" of
+ % whatever layout pdftex was dumped with.
+ \pdfhorigin = 1 true in
+ \pdfvorigin = 1 true in
+ \fi
+ %
+ \setleading{\textleading}
+ %
+ \parindent = \defaultparindent
+ \setemergencystretch
+}
+
+% @letterpaper (the default).
+\def\letterpaper{{\globaldefs = 1
+ \parskip = 3pt plus 2pt minus 1pt
+ \textleading = 13.2pt
+ %
+ % If page is nothing but text, make it come out even.
+ \internalpagesizes{607.2pt}{6in}% that's 46 lines
+ {\voffset}{.25in}%
+ {\bindingoffset}{36pt}%
+ {11in}{8.5in}%
+}}
+
+% Use @smallbook to reset parameters for 7x9.25 trim size.
+\def\smallbook{{\globaldefs = 1
+ \parskip = 2pt plus 1pt
+ \textleading = 12pt
+ %
+ \internalpagesizes{7.5in}{5in}%
+ {-.2in}{0in}%
+ {\bindingoffset}{16pt}%
+ {9.25in}{7in}%
+ %
+ \lispnarrowing = 0.3in
+ \tolerance = 700
+ \hfuzz = 1pt
+ \contentsrightmargin = 0pt
+ \defbodyindent = .5cm
+}}
+
+% Use @smallerbook to reset parameters for 6x9 trim size.
+% (Just testing, parameters still in flux.)
+\def\smallerbook{{\globaldefs = 1
+ \parskip = 1.5pt plus 1pt
+ \textleading = 12pt
+ %
+ \internalpagesizes{7.4in}{4.8in}%
+ {-.2in}{-.4in}%
+ {0pt}{14pt}%
+ {9in}{6in}%
+ %
+ \lispnarrowing = 0.25in
+ \tolerance = 700
+ \hfuzz = 1pt
+ \contentsrightmargin = 0pt
+ \defbodyindent = .4cm
+}}
+
+% Use @afourpaper to print on European A4 paper.
+\def\afourpaper{{\globaldefs = 1
+ \parskip = 3pt plus 2pt minus 1pt
+ \textleading = 13.2pt
+ %
+ % Double-side printing via postscript on Laserjet 4050
+ % prints double-sided nicely when \bindingoffset=10mm and \hoffset=-6mm.
+ % To change the settings for a different printer or situation, adjust
+ % \normaloffset until the front-side and back-side texts align. Then
+ % do the same for \bindingoffset. You can set these for testing in
+ % your texinfo source file like this:
+ % @tex
+ % \global\normaloffset = -6mm
+ % \global\bindingoffset = 10mm
+ % @end tex
+ \internalpagesizes{673.2pt}{160mm}% that's 51 lines
+ {\voffset}{\hoffset}%
+ {\bindingoffset}{44pt}%
+ {297mm}{210mm}%
+ %
+ \tolerance = 700
+ \hfuzz = 1pt
+ \contentsrightmargin = 0pt
+ \defbodyindent = 5mm
+}}
+
+% Use @afivepaper to print on European A5 paper.
+% From romildo@urano.iceb.ufop.br, 2 July 2000.
+% He also recommends making @example and @lisp be small.
+\def\afivepaper{{\globaldefs = 1
+ \parskip = 2pt plus 1pt minus 0.1pt
+ \textleading = 12.5pt
+ %
+ \internalpagesizes{160mm}{120mm}%
+ {\voffset}{\hoffset}%
+ {\bindingoffset}{8pt}%
+ {210mm}{148mm}%
+ %
+ \lispnarrowing = 0.2in
+ \tolerance = 800
+ \hfuzz = 1.2pt
+ \contentsrightmargin = 0pt
+ \defbodyindent = 2mm
+ \tableindent = 12mm
+}}
+
+% A specific text layout, 24x15cm overall, intended for A4 paper.
+\def\afourlatex{{\globaldefs = 1
+ \afourpaper
+ \internalpagesizes{237mm}{150mm}%
+ {\voffset}{4.6mm}%
+ {\bindingoffset}{7mm}%
+ {297mm}{210mm}%
+ %
+ % Must explicitly reset to 0 because we call \afourpaper.
+ \globaldefs = 0
+}}
+
+% Use @afourwide to print on A4 paper in landscape format.
+\def\afourwide{{\globaldefs = 1
+ \afourpaper
+ \internalpagesizes{241mm}{165mm}%
+ {\voffset}{-2.95mm}%
+ {\bindingoffset}{7mm}%
+ {297mm}{210mm}%
+ \globaldefs = 0
+}}
+
+% @pagesizes TEXTHEIGHT[,TEXTWIDTH]
+% Perhaps we should allow setting the margins, \topskip, \parskip,
+% and/or leading, also. Or perhaps we should compute them somehow.
+%
+\parseargdef\pagesizes{\pagesizesyyy #1,,\finish}
+\def\pagesizesyyy#1,#2,#3\finish{{%
+ \setbox0 = \hbox{\ignorespaces #2}\ifdim\wd0 > 0pt \hsize=#2\relax \fi
+ \globaldefs = 1
+ %
+ \parskip = 3pt plus 2pt minus 1pt
+ \setleading{\textleading}%
+ %
+ \dimen0 = #1\relax
+ \advance\dimen0 by \voffset
+ %
+ \dimen2 = \hsize
+ \advance\dimen2 by \normaloffset
+ %
+ \internalpagesizes{#1}{\hsize}%
+ {\voffset}{\normaloffset}%
+ {\bindingoffset}{44pt}%
+ {\dimen0}{\dimen2}%
+}}
+
+% Set default to letter.
+%
+\letterpaper
+
+
+\message{and turning on texinfo input format.}
+
+% Define macros to output various characters with catcode for normal text.
+\catcode`\"=\other
+\catcode`\~=\other
+\catcode`\^=\other
+\catcode`\_=\other
+\catcode`\|=\other
+\catcode`\<=\other
+\catcode`\>=\other
+\catcode`\+=\other
+\catcode`\$=\other
+\def\normaldoublequote{"}
+\def\normaltilde{~}
+\def\normalcaret{^}
+\def\normalunderscore{_}
+\def\normalverticalbar{|}
+\def\normalless{<}
+\def\normalgreater{>}
+\def\normalplus{+}
+\def\normaldollar{$}%$ font-lock fix
+
+% This macro is used to make a character print one way in \tt
+% (where it can probably be output as-is), and another way in other fonts,
+% where something hairier probably needs to be done.
+%
+% #1 is what to print if we are indeed using \tt; #2 is what to print
+% otherwise. Since all the Computer Modern typewriter fonts have zero
+% interword stretch (and shrink), and it is reasonable to expect all
+% typewriter fonts to have this, we can check that font parameter.
+%
+\def\ifusingtt#1#2{\ifdim \fontdimen3\font=0pt #1\else #2\fi}
+
+% Same as above, but check for italic font. Actually this also catches
+% non-italic slanted fonts since it is impossible to distinguish them from
+% italic fonts. But since this is only used by $ and it uses \sl anyway
+% this is not a problem.
+\def\ifusingit#1#2{\ifdim \fontdimen1\font>0pt #1\else #2\fi}
+
+% Turn off all special characters except @
+% (and those which the user can use as if they were ordinary).
+% Most of these we simply print from the \tt font, but for some, we can
+% use math or other variants that look better in normal text.
+
+\catcode`\"=\active
+\def\activedoublequote{{\tt\char34}}
+\let"=\activedoublequote
+\catcode`\~=\active
+\def~{{\tt\char126}}
+\chardef\hat=`\^
+\catcode`\^=\active
+\def^{{\tt \hat}}
+
+\catcode`\_=\active
+\def_{\ifusingtt\normalunderscore\_}
+\let\realunder=_
+% Subroutine for the previous macro.
+\def\_{\leavevmode \kern.07em \vbox{\hrule width.3em height.1ex}\kern .07em }
+
+\catcode`\|=\active
+\def|{{\tt\char124}}
+\chardef \less=`\<
+\catcode`\<=\active
+\def<{{\tt \less}}
+\chardef \gtr=`\>
+\catcode`\>=\active
+\def>{{\tt \gtr}}
+\catcode`\+=\active
+\def+{{\tt \char 43}}
+\catcode`\$=\active
+\def${\ifusingit{{\sl\$}}\normaldollar}%$ font-lock fix
+
+% If a .fmt file is being used, characters that might appear in a file
+% name cannot be active until we have parsed the command line.
+% So turn them off again, and have \everyjob (or @setfilename) turn them on.
+% \otherifyactive is called near the end of this file.
+\def\otherifyactive{\catcode`+=\other \catcode`\_=\other}
+
+% Used sometimes to turn off (effectively) the active characters even after
+% parsing them.
+\def\turnoffactive{%
+ \normalturnoffactive
+ \otherbackslash
+}
+
+\catcode`\@=0
+
+% \backslashcurfont outputs one backslash character in current font,
+% as in \char`\\.
+\global\chardef\backslashcurfont=`\\
+\global\let\rawbackslashxx=\backslashcurfont % let existing .??s files work
+
+% \realbackslash is an actual character `\' with catcode other, and
+% \doublebackslash is two of them (for the pdf outlines).
+{\catcode`\\=\other @gdef@realbackslash{\} @gdef@doublebackslash{\\}}
+
+% In texinfo, backslash is an active character; it prints the backslash
+% in fixed width font.
+\catcode`\\=\active
+@def@normalbackslash{{@tt@backslashcurfont}}
+% On startup, @fixbackslash assigns:
+% @let \ = @normalbackslash
+
+% \rawbackslash defines an active \ to do \backslashcurfont.
+% \otherbackslash defines an active \ to be a literal `\' character with
+% catcode other.
+@gdef@rawbackslash{@let\=@backslashcurfont}
+@gdef@otherbackslash{@let\=@realbackslash}
+
+% Same as @turnoffactive except outputs \ as {\tt\char`\\} instead of
+% the literal character `\'.
+%
+@def@normalturnoffactive{%
+ @let\=@normalbackslash
+ @let"=@normaldoublequote
+ @let~=@normaltilde
+ @let^=@normalcaret
+ @let_=@normalunderscore
+ @let|=@normalverticalbar
+ @let<=@normalless
+ @let>=@normalgreater
+ @let+=@normalplus
+ @let$=@normaldollar %$ font-lock fix
+ @unsepspaces
+}
+
+% Make _ and + \other characters, temporarily.
+% This is canceled by @fixbackslash.
+@otherifyactive
+
+% If a .fmt file is being used, we don't want the `\input texinfo' to show up.
+% That is what \eatinput is for; after that, the `\' should revert to printing
+% a backslash.
+%
+@gdef@eatinput input texinfo{@fixbackslash}
+@global@let\ = @eatinput
+
+% On the other hand, perhaps the file did not have a `\input texinfo'. Then
+% the first `\' in the file would cause an error. This macro tries to fix
+% that, assuming it is called before the first `\' could plausibly occur.
+% Also turn back on active characters that might appear in the input
+% file name, in case not using a pre-dumped format.
+%
+@gdef@fixbackslash{%
+ @ifx\@eatinput @let\ = @normalbackslash @fi
+ @catcode`+=@active
+ @catcode`@_=@active
+}
+
+% Say @foo, not \foo, in error messages.
+@escapechar = `@@
+
+% These look ok in all fonts, so just make them not special.
+@catcode`@& = @other
+@catcode`@# = @other
+@catcode`@% = @other
+
+
+@c Local variables:
+@c eval: (add-hook 'write-file-hooks 'time-stamp)
+@c page-delimiter: "^\\\\message"
+@c time-stamp-start: "def\\\\texinfoversion{"
+@c time-stamp-format: "%:y-%02m-%02d.%02H"
+@c time-stamp-end: "}"
+@c End:
+
+@c vim:sw=2:
+
+@ignore
+ arch-tag: e1b36e32-c96e-4135-a41a-0b2efa2ea115
+@end ignore
--- /dev/null
+#!/bin/sh
+
+# Copyright (C) 2002, 2006, 2008 Free Software Foundation
+#
+# This file is part of GUILE.
+#
+# GUILE 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.
+#
+# GUILE 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 GUILE; see the file COPYING. If not, write
+# to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+# Floor, Boston, MA 02110-1301 USA
+
+# Commentary:
+
+# Usage: gdb-pre-inst-guile [ARGS]
+#
+# This script runs Guile from the build tree under GDB. See
+# ./pre-inst-guile for more information.
+#
+# In addition to running ./gdb-pre-inst-guile, sometimes it's useful to
+# run e.g. ./check-guile -i ./gdb-pre-inst-guile foo.test.
+
+# Code:
+
+set -e
+# env (set by configure)
+top_builddir="@top_builddir_absolute@"
+exec ${top_builddir}/pre-inst-guile-env libtool --mode=execute \
+ gdb --args ${top_builddir}/libguile/guile "$@"
--- /dev/null
+# -*- GDB-Script -*-
+
+define newline
+ call (void)scm_newline (scm_current_error_port ())
+end
+
+define pp
+ call (void)scm_call_1 (scm_variable_ref (scm_c_module_lookup (scm_c_resolve_module ("ice-9 pretty-print"), "pretty-print")), $arg0)
+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_objcode
+ smobdatatox $arg0
+ set $objcode=$x
+ smobdatatox $objcode
+ p *(struct scm_objcode*)$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 vmstackinit
+ set $vmsp=sp
+ set $vmstack_base=stack_base
+ set $vmfp=fp
+ set $vmbp=bp
+ set $vmframe=0
+end
+
+define nextframe
+ 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 "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
+ set $vmfp=$vmdl
+ set $vmbp=(struct scm_objcode*)((SCM*)(((SCM*)($vmfp[-1]))[1])[1])
+ set $vmstack_base=$vmfp+$vmbp->nargs+$vmbp->nlocs+4
+ set $vmframe=$vmframe+1
+ newline
+ end
+end
+
+define vmstack
+ vmstackinit
+ while $vmsp > vp->stack_base
+ nextframe
+ end
+end
+
+define inst
+ p scm_instruction_table[$arg0]
+end
(set-buffered-input-continuation?! (readline-port) #f)
(set-readline-prompt! repl-prompt "... ")
(set-readline-read-hook! repl-read-hook))
- (lambda () (read))
+ (lambda () ((or (fluid-ref current-reader) read)))
(lambda ()
(set-readline-prompt! outer-new-input-prompt outer-continuation-prompt)
(set-readline-read-hook! outer-read-hook))))))
+++ /dev/null
-(letrec ((syntmp-lambda-var-list-164 (lambda (syntmp-vars-549) (let syntmp-lvl-550 ((syntmp-vars-551 syntmp-vars-549) (syntmp-ls-552 (quote ())) (syntmp-w-553 (quote (())))) (cond ((pair? syntmp-vars-551) (syntmp-lvl-550 (cdr syntmp-vars-551) (cons (syntmp-wrap-143 (car syntmp-vars-551) syntmp-w-553) syntmp-ls-552) syntmp-w-553)) ((syntmp-id?-115 syntmp-vars-551) (cons (syntmp-wrap-143 syntmp-vars-551 syntmp-w-553) syntmp-ls-552)) ((null? syntmp-vars-551) syntmp-ls-552) ((syntmp-syntax-object?-101 syntmp-vars-551) (syntmp-lvl-550 (syntmp-syntax-object-expression-102 syntmp-vars-551) syntmp-ls-552 (syntmp-join-wraps-134 syntmp-w-553 (syntmp-syntax-object-wrap-103 syntmp-vars-551)))) ((syntmp-annotation?-89 syntmp-vars-551) (syntmp-lvl-550 (annotation-expression syntmp-vars-551) syntmp-ls-552 syntmp-w-553)) (else (cons syntmp-vars-551 syntmp-ls-552)))))) (syntmp-gen-var-163 (lambda (syntmp-id-554) (let ((syntmp-id-555 (if (syntmp-syntax-object?-101 syntmp-id-554) (syntmp-syntax-object-expression-102 syntmp-id-554) syntmp-id-554))) (if (syntmp-annotation?-89 syntmp-id-555) (gensym (symbol->string (annotation-expression syntmp-id-555))) (gensym (symbol->string syntmp-id-555)))))) (syntmp-strip-162 (lambda (syntmp-x-556 syntmp-w-557) (if (memq (quote top) (syntmp-wrap-marks-118 syntmp-w-557)) (if (or (syntmp-annotation?-89 syntmp-x-556) (and (pair? syntmp-x-556) (syntmp-annotation?-89 (car syntmp-x-556)))) (syntmp-strip-annotation-161 syntmp-x-556 #f) syntmp-x-556) (let syntmp-f-558 ((syntmp-x-559 syntmp-x-556)) (cond ((syntmp-syntax-object?-101 syntmp-x-559) (syntmp-strip-162 (syntmp-syntax-object-expression-102 syntmp-x-559) (syntmp-syntax-object-wrap-103 syntmp-x-559))) ((pair? syntmp-x-559) (let ((syntmp-a-560 (syntmp-f-558 (car syntmp-x-559))) (syntmp-d-561 (syntmp-f-558 (cdr syntmp-x-559)))) (if (and (eq? syntmp-a-560 (car syntmp-x-559)) (eq? syntmp-d-561 (cdr syntmp-x-559))) syntmp-x-559 (cons syntmp-a-560 syntmp-d-561)))) ((vector? syntmp-x-559) (let ((syntmp-old-562 (vector->list syntmp-x-559))) (let ((syntmp-new-563 (map syntmp-f-558 syntmp-old-562))) (if (andmap eq? syntmp-old-562 syntmp-new-563) syntmp-x-559 (list->vector syntmp-new-563))))) (else syntmp-x-559)))))) (syntmp-strip-annotation-161 (lambda (syntmp-x-564 syntmp-parent-565) (cond ((pair? syntmp-x-564) (let ((syntmp-new-566 (cons #f #f))) (begin (when syntmp-parent-565 (set-annotation-stripped! syntmp-parent-565 syntmp-new-566)) (set-car! syntmp-new-566 (syntmp-strip-annotation-161 (car syntmp-x-564) #f)) (set-cdr! syntmp-new-566 (syntmp-strip-annotation-161 (cdr syntmp-x-564) #f)) syntmp-new-566))) ((syntmp-annotation?-89 syntmp-x-564) (or (annotation-stripped syntmp-x-564) (syntmp-strip-annotation-161 (annotation-expression syntmp-x-564) syntmp-x-564))) ((vector? syntmp-x-564) (let ((syntmp-new-567 (make-vector (vector-length syntmp-x-564)))) (begin (when syntmp-parent-565 (set-annotation-stripped! syntmp-parent-565 syntmp-new-567)) (let syntmp-loop-568 ((syntmp-i-569 (- (vector-length syntmp-x-564) 1))) (unless (syntmp-fx<-88 syntmp-i-569 0) (vector-set! syntmp-new-567 syntmp-i-569 (syntmp-strip-annotation-161 (vector-ref syntmp-x-564 syntmp-i-569) #f)) (syntmp-loop-568 (syntmp-fx--86 syntmp-i-569 1)))) syntmp-new-567))) (else syntmp-x-564)))) (syntmp-ellipsis?-160 (lambda (syntmp-x-570) (and (syntmp-nonsymbol-id?-114 syntmp-x-570) (syntmp-free-id=?-138 syntmp-x-570 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application 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) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-159 (lambda () (list (quote void)))) (syntmp-eval-local-transformer-158 (lambda (syntmp-expanded-571) (let ((syntmp-p-572 (syntmp-local-eval-hook-91 syntmp-expanded-571))) (if (procedure? syntmp-p-572) syntmp-p-572 (syntax-error syntmp-p-572 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-157 (lambda (syntmp-rec?-573 syntmp-e-574 syntmp-r-575 syntmp-w-576 syntmp-s-577 syntmp-k-578) ((lambda (syntmp-tmp-579) ((lambda (syntmp-tmp-580) (if syntmp-tmp-580 (apply (lambda (syntmp-_-581 syntmp-id-582 syntmp-val-583 syntmp-e1-584 syntmp-e2-585) (let ((syntmp-ids-586 syntmp-id-582)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-586)) (syntax-error syntmp-e-574 "duplicate bound keyword in") (let ((syntmp-labels-588 (syntmp-gen-labels-121 syntmp-ids-586))) (let ((syntmp-new-w-589 (syntmp-make-binding-wrap-132 syntmp-ids-586 syntmp-labels-588 syntmp-w-576))) (syntmp-k-578 (cons syntmp-e1-584 syntmp-e2-585) (syntmp-extend-env-109 syntmp-labels-588 (let ((syntmp-w-591 (if syntmp-rec?-573 syntmp-new-w-589 syntmp-w-576)) (syntmp-trans-r-592 (syntmp-macros-only-env-111 syntmp-r-575))) (map (lambda (syntmp-x-593) (cons (quote macro) (syntmp-eval-local-transformer-158 (syntmp-chi-151 syntmp-x-593 syntmp-trans-r-592 syntmp-w-591)))) syntmp-val-583)) syntmp-r-575) syntmp-new-w-589 syntmp-s-577)))))) syntmp-tmp-580) ((lambda (syntmp-_-595) (syntax-error (syntmp-source-wrap-144 syntmp-e-574 syntmp-w-576 syntmp-s-577))) syntmp-tmp-579))) (syntax-dispatch syntmp-tmp-579 (quote (any #(each (any any)) any . each-any))))) syntmp-e-574))) (syntmp-chi-lambda-clause-156 (lambda (syntmp-e-596 syntmp-c-597 syntmp-r-598 syntmp-w-599 syntmp-k-600) ((lambda (syntmp-tmp-601) ((lambda (syntmp-tmp-602) (if syntmp-tmp-602 (apply (lambda (syntmp-id-603 syntmp-e1-604 syntmp-e2-605) (let ((syntmp-ids-606 syntmp-id-603)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-606)) (syntax-error syntmp-e-596 "invalid parameter list in") (let ((syntmp-labels-608 (syntmp-gen-labels-121 syntmp-ids-606)) (syntmp-new-vars-609 (map syntmp-gen-var-163 syntmp-ids-606))) (syntmp-k-600 syntmp-new-vars-609 (syntmp-chi-body-155 (cons syntmp-e1-604 syntmp-e2-605) syntmp-e-596 (syntmp-extend-var-env-110 syntmp-labels-608 syntmp-new-vars-609 syntmp-r-598) (syntmp-make-binding-wrap-132 syntmp-ids-606 syntmp-labels-608 syntmp-w-599))))))) syntmp-tmp-602) ((lambda (syntmp-tmp-611) (if syntmp-tmp-611 (apply (lambda (syntmp-ids-612 syntmp-e1-613 syntmp-e2-614) (let ((syntmp-old-ids-615 (syntmp-lambda-var-list-164 syntmp-ids-612))) (if (not (syntmp-valid-bound-ids?-140 syntmp-old-ids-615)) (syntax-error syntmp-e-596 "invalid parameter list in") (let ((syntmp-labels-616 (syntmp-gen-labels-121 syntmp-old-ids-615)) (syntmp-new-vars-617 (map syntmp-gen-var-163 syntmp-old-ids-615))) (syntmp-k-600 (let syntmp-f-618 ((syntmp-ls1-619 (cdr syntmp-new-vars-617)) (syntmp-ls2-620 (car syntmp-new-vars-617))) (if (null? syntmp-ls1-619) syntmp-ls2-620 (syntmp-f-618 (cdr syntmp-ls1-619) (cons (car syntmp-ls1-619) syntmp-ls2-620)))) (syntmp-chi-body-155 (cons syntmp-e1-613 syntmp-e2-614) syntmp-e-596 (syntmp-extend-var-env-110 syntmp-labels-616 syntmp-new-vars-617 syntmp-r-598) (syntmp-make-binding-wrap-132 syntmp-old-ids-615 syntmp-labels-616 syntmp-w-599))))))) syntmp-tmp-611) ((lambda (syntmp-_-622) (syntax-error syntmp-e-596)) syntmp-tmp-601))) (syntax-dispatch syntmp-tmp-601 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-601 (quote (each-any any . each-any))))) syntmp-c-597))) (syntmp-chi-body-155 (lambda (syntmp-body-623 syntmp-outer-form-624 syntmp-r-625 syntmp-w-626) (let ((syntmp-r-627 (cons (quote ("placeholder" placeholder)) syntmp-r-625))) (let ((syntmp-ribcage-628 (syntmp-make-ribcage-122 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-629 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w-626) (cons syntmp-ribcage-628 (syntmp-wrap-subst-119 syntmp-w-626))))) (let syntmp-parse-630 ((syntmp-body-631 (map (lambda (syntmp-x-637) (cons syntmp-r-627 (syntmp-wrap-143 syntmp-x-637 syntmp-w-629))) syntmp-body-623)) (syntmp-ids-632 (quote ())) (syntmp-labels-633 (quote ())) (syntmp-vars-634 (quote ())) (syntmp-vals-635 (quote ())) (syntmp-bindings-636 (quote ()))) (if (null? syntmp-body-631) (syntax-error syntmp-outer-form-624 "no expressions in body") (let ((syntmp-e-638 (cdar syntmp-body-631)) (syntmp-er-639 (caar syntmp-body-631))) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-638 syntmp-er-639 (quote (())) #f syntmp-ribcage-628)) (lambda (syntmp-type-640 syntmp-value-641 syntmp-e-642 syntmp-w-643 syntmp-s-644) (let ((syntmp-t-645 syntmp-type-640)) (if (memv syntmp-t-645 (quote (define-form))) (let ((syntmp-id-646 (syntmp-wrap-143 syntmp-value-641 syntmp-w-643)) (syntmp-label-647 (syntmp-gen-label-120))) (let ((syntmp-var-648 (syntmp-gen-var-163 syntmp-id-646))) (begin (syntmp-extend-ribcage!-131 syntmp-ribcage-628 syntmp-id-646 syntmp-label-647) (syntmp-parse-630 (cdr syntmp-body-631) (cons syntmp-id-646 syntmp-ids-632) (cons syntmp-label-647 syntmp-labels-633) (cons syntmp-var-648 syntmp-vars-634) (cons (cons syntmp-er-639 (syntmp-wrap-143 syntmp-e-642 syntmp-w-643)) syntmp-vals-635) (cons (cons (quote lexical) syntmp-var-648) syntmp-bindings-636))))) (if (memv syntmp-t-645 (quote (define-syntax-form))) (let ((syntmp-id-649 (syntmp-wrap-143 syntmp-value-641 syntmp-w-643)) (syntmp-label-650 (syntmp-gen-label-120))) (begin (syntmp-extend-ribcage!-131 syntmp-ribcage-628 syntmp-id-649 syntmp-label-650) (syntmp-parse-630 (cdr syntmp-body-631) (cons syntmp-id-649 syntmp-ids-632) (cons syntmp-label-650 syntmp-labels-633) syntmp-vars-634 syntmp-vals-635 (cons (cons (quote macro) (cons syntmp-er-639 (syntmp-wrap-143 syntmp-e-642 syntmp-w-643))) syntmp-bindings-636)))) (if (memv syntmp-t-645 (quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-630 (let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null? syntmp-forms-656) (cdr syntmp-body-631) (cons (cons syntmp-er-639 (syntmp-wrap-143 (car syntmp-forms-656) syntmp-w-643)) (syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-632 syntmp-labels-633 syntmp-vars-634 syntmp-vals-635 syntmp-bindings-636)) syntmp-tmp-652) (syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any . each-any))))) syntmp-e-642) (if (memv syntmp-t-645 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-641 syntmp-e-642 syntmp-er-639 syntmp-w-643 syntmp-s-644 (lambda (syntmp-forms-658 syntmp-er-659 syntmp-w-660 syntmp-s-661) (syntmp-parse-630 (let syntmp-f-662 ((syntmp-forms-663 syntmp-forms-658)) (if (null? syntmp-forms-663) (cdr syntmp-body-631) (cons (cons syntmp-er-659 (syntmp-wrap-143 (car syntmp-forms-663) syntmp-w-660)) (syntmp-f-662 (cdr syntmp-forms-663))))) syntmp-ids-632 syntmp-labels-633 syntmp-vars-634 syntmp-vals-635 syntmp-bindings-636))) (if (null? syntmp-ids-632) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-664) (syntmp-chi-151 (cdr syntmp-x-664) (car syntmp-x-664) (quote (())))) (cons (cons syntmp-er-639 (syntmp-source-wrap-144 syntmp-e-642 syntmp-w-643 syntmp-s-644)) (cdr syntmp-body-631)))) (begin (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-632)) (syntax-error syntmp-outer-form-624 "invalid or duplicate identifier in definition")) (let syntmp-loop-665 ((syntmp-bs-666 syntmp-bindings-636) (syntmp-er-cache-667 #f) (syntmp-r-cache-668 #f)) (if (not (null? syntmp-bs-666)) (let ((syntmp-b-669 (car syntmp-bs-666))) (if (eq? (car syntmp-b-669) (quote macro)) (let ((syntmp-er-670 (cadr syntmp-b-669))) (let ((syntmp-r-cache-671 (if (eq? syntmp-er-670 syntmp-er-cache-667) syntmp-r-cache-668 (syntmp-macros-only-env-111 syntmp-er-670)))) (begin (set-cdr! syntmp-b-669 (syntmp-eval-local-transformer-158 (syntmp-chi-151 (cddr syntmp-b-669) syntmp-r-cache-671 (quote (()))))) (syntmp-loop-665 (cdr syntmp-bs-666) syntmp-er-670 syntmp-r-cache-671)))) (syntmp-loop-665 (cdr syntmp-bs-666) syntmp-er-cache-667 syntmp-r-cache-668))))) (set-cdr! syntmp-r-627 (syntmp-extend-env-109 syntmp-labels-633 syntmp-bindings-636 (cdr syntmp-r-627))) (syntmp-build-letrec-99 #f syntmp-vars-634 (map (lambda (syntmp-x-672) (syntmp-chi-151 (cdr syntmp-x-672) (car syntmp-x-672) (quote (())))) syntmp-vals-635) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-673) (syntmp-chi-151 (cdr syntmp-x-673) (car syntmp-x-673) (quote (())))) (cons (cons syntmp-er-639 (syntmp-source-wrap-144 syntmp-e-642 syntmp-w-643 syntmp-s-644)) (cdr syntmp-body-631)))))))))))))))))))))) (syntmp-chi-macro-154 (lambda (syntmp-p-674 syntmp-e-675 syntmp-r-676 syntmp-w-677 syntmp-rib-678) (letrec ((syntmp-rebuild-macro-output-679 (lambda (syntmp-x-680 syntmp-m-681) (cond ((pair? syntmp-x-680) (cons (syntmp-rebuild-macro-output-679 (car syntmp-x-680) syntmp-m-681) (syntmp-rebuild-macro-output-679 (cdr syntmp-x-680) syntmp-m-681))) ((syntmp-syntax-object?-101 syntmp-x-680) (let ((syntmp-w-682 (syntmp-syntax-object-wrap-103 syntmp-x-680))) (let ((syntmp-ms-683 (syntmp-wrap-marks-118 syntmp-w-682)) (syntmp-s-684 (syntmp-wrap-subst-119 syntmp-w-682))) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-680) (if (and (pair? syntmp-ms-683) (eq? (car syntmp-ms-683) #f)) (syntmp-make-wrap-117 (cdr syntmp-ms-683) (if syntmp-rib-678 (cons syntmp-rib-678 (cdr syntmp-s-684)) (cdr syntmp-s-684))) (syntmp-make-wrap-117 (cons syntmp-m-681 syntmp-ms-683) (if syntmp-rib-678 (cons syntmp-rib-678 (cons (quote shift) syntmp-s-684)) (cons (quote shift) syntmp-s-684)))))))) ((vector? syntmp-x-680) (let ((syntmp-n-685 (vector-length syntmp-x-680))) (let ((syntmp-v-686 (make-vector syntmp-n-685))) (let syntmp-doloop-687 ((syntmp-i-688 0)) (if (syntmp-fx=-87 syntmp-i-688 syntmp-n-685) syntmp-v-686 (begin (vector-set! syntmp-v-686 syntmp-i-688 (syntmp-rebuild-macro-output-679 (vector-ref syntmp-x-680 syntmp-i-688) syntmp-m-681)) (syntmp-doloop-687 (syntmp-fx+-85 syntmp-i-688 1)))))))) ((symbol? syntmp-x-680) (syntax-error syntmp-x-680 "encountered raw symbol in macro output")) (else syntmp-x-680))))) (syntmp-rebuild-macro-output-679 (syntmp-p-674 (syntmp-wrap-143 syntmp-e-675 (syntmp-anti-mark-130 syntmp-w-677))) (string #\m))))) (syntmp-chi-application-153 (lambda (syntmp-x-689 syntmp-e-690 syntmp-r-691 syntmp-w-692 syntmp-s-693) ((lambda (syntmp-tmp-694) ((lambda (syntmp-tmp-695) (if syntmp-tmp-695 (apply (lambda (syntmp-e0-696 syntmp-e1-697) (cons syntmp-x-689 (map (lambda (syntmp-e-698) (syntmp-chi-151 syntmp-e-698 syntmp-r-691 syntmp-w-692)) syntmp-e1-697))) syntmp-tmp-695) (syntax-error syntmp-tmp-694))) (syntax-dispatch syntmp-tmp-694 (quote (any . each-any))))) syntmp-e-690))) (syntmp-chi-expr-152 (lambda (syntmp-type-700 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (let ((syntmp-t-706 syntmp-type-700)) (if (memv syntmp-t-706 (quote (lexical))) syntmp-value-701 (if (memv syntmp-t-706 (quote (core external-macro))) (syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (lexical-call))) (syntmp-chi-application-153 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (global-call))) (syntmp-chi-application-153 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (constant))) (syntmp-build-data-95 syntmp-s-705 (syntmp-strip-162 (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) (quote (())))) (if (memv syntmp-t-706 (quote (global))) syntmp-value-701 (if (memv syntmp-t-706 (quote (call))) (syntmp-chi-application-153 (syntmp-chi-151 (car syntmp-e-702) syntmp-r-703 syntmp-w-704) syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (begin-form))) ((lambda (syntmp-tmp-707) ((lambda (syntmp-tmp-708) (if syntmp-tmp-708 (apply (lambda (syntmp-_-709 syntmp-e1-710 syntmp-e2-711) (syntmp-chi-sequence-145 (cons syntmp-e1-710 syntmp-e2-711) syntmp-r-703 syntmp-w-704 syntmp-s-705)) syntmp-tmp-708) (syntax-error syntmp-tmp-707))) (syntax-dispatch syntmp-tmp-707 (quote (any any . each-any))))) syntmp-e-702) (if (memv syntmp-t-706 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705 syntmp-chi-sequence-145) (if (memv syntmp-t-706 (quote (eval-when-form))) ((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply (lambda (syntmp-_-715 syntmp-x-716 syntmp-e1-717 syntmp-e2-718) (let ((syntmp-when-list-719 (syntmp-chi-when-list-148 syntmp-e-702 syntmp-x-716 syntmp-w-704))) (if (memq (quote eval) syntmp-when-list-719) (syntmp-chi-sequence-145 (cons syntmp-e1-717 syntmp-e2-718) syntmp-r-703 syntmp-w-704 syntmp-s-705) (syntmp-chi-void-159)))) syntmp-tmp-714) (syntax-error syntmp-tmp-713))) (syntax-dispatch syntmp-tmp-713 (quote (any each-any any . each-any))))) syntmp-e-702) (if (memv syntmp-t-706 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-143 syntmp-value-701 syntmp-w-704) "invalid context for definition of") (if (memv syntmp-t-706 (quote (syntax))) (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) "reference to pattern variable outside syntax form") (if (memv syntmp-t-706 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705)))))))))))))))))) (syntmp-chi-151 (lambda (syntmp-e-722 syntmp-r-723 syntmp-w-724) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-722 syntmp-r-723 syntmp-w-724 #f #f)) (lambda (syntmp-type-725 syntmp-value-726 syntmp-e-727 syntmp-w-728 syntmp-s-729) (syntmp-chi-expr-152 syntmp-type-725 syntmp-value-726 syntmp-e-727 syntmp-r-723 syntmp-w-728 syntmp-s-729))))) (syntmp-chi-top-150 (lambda (syntmp-e-730 syntmp-r-731 syntmp-w-732 syntmp-m-733 syntmp-esew-734) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-730 syntmp-r-731 syntmp-w-732 #f #f)) (lambda (syntmp-type-747 syntmp-value-748 syntmp-e-749 syntmp-w-750 syntmp-s-751) (let ((syntmp-t-752 syntmp-type-747)) (if (memv syntmp-t-752 (quote (begin-form))) ((lambda (syntmp-tmp-753) ((lambda (syntmp-tmp-754) (if syntmp-tmp-754 (apply (lambda (syntmp-_-755) (syntmp-chi-void-159)) syntmp-tmp-754) ((lambda (syntmp-tmp-756) (if syntmp-tmp-756 (apply (lambda (syntmp-_-757 syntmp-e1-758 syntmp-e2-759) (syntmp-chi-top-sequence-146 (cons syntmp-e1-758 syntmp-e2-759) syntmp-r-731 syntmp-w-750 syntmp-s-751 syntmp-m-733 syntmp-esew-734)) syntmp-tmp-756) (syntax-error syntmp-tmp-753))) (syntax-dispatch syntmp-tmp-753 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-753 (quote (any))))) syntmp-e-749) (if (memv syntmp-t-752 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-748 syntmp-e-749 syntmp-r-731 syntmp-w-750 syntmp-s-751 (lambda (syntmp-body-761 syntmp-r-762 syntmp-w-763 syntmp-s-764) (syntmp-chi-top-sequence-146 syntmp-body-761 syntmp-r-762 syntmp-w-763 syntmp-s-764 syntmp-m-733 syntmp-esew-734))) (if (memv syntmp-t-752 (quote (eval-when-form))) ((lambda (syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda (syntmp-_-767 syntmp-x-768 syntmp-e1-769 syntmp-e2-770) (let ((syntmp-when-list-771 (syntmp-chi-when-list-148 syntmp-e-749 syntmp-x-768 syntmp-w-750)) (syntmp-body-772 (cons syntmp-e1-769 syntmp-e2-770))) (cond ((eq? syntmp-m-733 (quote e)) (if (memq (quote eval) syntmp-when-list-771) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote e) (quote (eval))) (syntmp-chi-void-159))) ((memq (quote load) syntmp-when-list-771) (if (or (memq (quote compile) syntmp-when-list-771) (and (eq? syntmp-m-733 (quote c&e)) (memq (quote eval) syntmp-when-list-771))) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote c&e) (quote (compile load))) (if (memq syntmp-m-733 (quote (c c&e))) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote c) (quote (load))) (syntmp-chi-void-159)))) ((or (memq (quote compile) syntmp-when-list-771) (and (eq? syntmp-m-733 (quote c&e)) (memq (quote eval) syntmp-when-list-771))) (syntmp-top-level-eval-hook-90 (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote e) (quote (eval)))) (syntmp-chi-void-159)) (else (syntmp-chi-void-159))))) syntmp-tmp-766) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765 (quote (any each-any any . each-any))))) syntmp-e-749) (if (memv syntmp-t-752 (quote (define-syntax-form))) (let ((syntmp-n-775 (syntmp-id-var-name-137 syntmp-value-748 syntmp-w-750)) (syntmp-r-776 (syntmp-macros-only-env-111 syntmp-r-731))) (let ((syntmp-t-777 syntmp-m-733)) (if (memv syntmp-t-777 (quote (c))) (if (memq (quote compile) syntmp-esew-734) (let ((syntmp-e-778 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (begin (syntmp-top-level-eval-hook-90 syntmp-e-778) (if (memq (quote load) syntmp-esew-734) syntmp-e-778 (syntmp-chi-void-159)))) (if (memq (quote load) syntmp-esew-734) (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)) (syntmp-chi-void-159))) (if (memv syntmp-t-777 (quote (c&e))) (let ((syntmp-e-779 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (begin (syntmp-top-level-eval-hook-90 syntmp-e-779) syntmp-e-779)) (begin (if (memq (quote eval) syntmp-esew-734) (syntmp-top-level-eval-hook-90 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (syntmp-chi-void-159)))))) (if (memv syntmp-t-752 (quote (define-form))) (let ((syntmp-n-780 (syntmp-id-var-name-137 syntmp-value-748 syntmp-w-750))) (let ((syntmp-type-781 (syntmp-binding-type-107 (syntmp-lookup-112 syntmp-n-780 syntmp-r-731)))) (let ((syntmp-t-782 syntmp-type-781)) (if (memv syntmp-t-782 (quote (global))) (let ((syntmp-x-783 (list (quote define) syntmp-n-780 (syntmp-chi-151 syntmp-e-749 syntmp-r-731 syntmp-w-750)))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-90 syntmp-x-783)) syntmp-x-783)) (if (memv syntmp-t-782 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-143 syntmp-value-748 syntmp-w-750) "identifier out of context") (if (eq? syntmp-type-781 (quote external-macro)) (let ((syntmp-x-784 (list (quote define) syntmp-n-780 (syntmp-chi-151 syntmp-e-749 syntmp-r-731 syntmp-w-750)))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-90 syntmp-x-784)) syntmp-x-784)) (syntax-error (syntmp-wrap-143 syntmp-value-748 syntmp-w-750) "cannot define keyword at top level"))))))) (let ((syntmp-x-785 (syntmp-chi-expr-152 syntmp-type-747 syntmp-value-748 syntmp-e-749 syntmp-r-731 syntmp-w-750 syntmp-s-751))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-90 syntmp-x-785)) syntmp-x-785)))))))))))) (syntmp-syntax-type-149 (lambda (syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-rib-790) (cond ((symbol? syntmp-e-786) (let ((syntmp-n-791 (syntmp-id-var-name-137 syntmp-e-786 syntmp-w-788))) (let ((syntmp-b-792 (syntmp-lookup-112 syntmp-n-791 syntmp-r-787))) (let ((syntmp-type-793 (syntmp-binding-type-107 syntmp-b-792))) (let ((syntmp-t-794 syntmp-type-793)) (if (memv syntmp-t-794 (quote (lexical))) (values syntmp-type-793 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-794 (quote (global))) (values syntmp-type-793 syntmp-n-791 syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-794 (quote (macro))) (syntmp-syntax-type-149 (syntmp-chi-macro-154 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-rib-790) syntmp-r-787 (quote (())) syntmp-s-789 syntmp-rib-790) (values syntmp-type-793 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-w-788 syntmp-s-789))))))))) ((pair? syntmp-e-786) (let ((syntmp-first-795 (car syntmp-e-786))) (if (syntmp-id?-115 syntmp-first-795) (let ((syntmp-n-796 (syntmp-id-var-name-137 syntmp-first-795 syntmp-w-788))) (let ((syntmp-b-797 (syntmp-lookup-112 syntmp-n-796 syntmp-r-787))) (let ((syntmp-type-798 (syntmp-binding-type-107 syntmp-b-797))) (let ((syntmp-t-799 syntmp-type-798)) (if (memv syntmp-t-799 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (global))) (values (quote global-call) syntmp-n-796 syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (macro))) (syntmp-syntax-type-149 (syntmp-chi-macro-154 (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-rib-790) syntmp-r-787 (quote (())) syntmp-s-789 syntmp-rib-790) (if (memv syntmp-t-799 (quote (core external-macro))) (values syntmp-type-798 (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (begin))) (values (quote begin-form) #f syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (define))) ((lambda (syntmp-tmp-800) ((lambda (syntmp-tmp-801) (if (if syntmp-tmp-801 (apply (lambda (syntmp-_-802 syntmp-name-803 syntmp-val-804) (syntmp-id?-115 syntmp-name-803)) syntmp-tmp-801) #f) (apply (lambda (syntmp-_-805 syntmp-name-806 syntmp-val-807) (values (quote define-form) syntmp-name-806 syntmp-val-807 syntmp-w-788 syntmp-s-789)) syntmp-tmp-801) ((lambda (syntmp-tmp-808) (if (if syntmp-tmp-808 (apply (lambda (syntmp-_-809 syntmp-name-810 syntmp-args-811 syntmp-e1-812 syntmp-e2-813) (and (syntmp-id?-115 syntmp-name-810) (syntmp-valid-bound-ids?-140 (syntmp-lambda-var-list-164 syntmp-args-811)))) syntmp-tmp-808) #f) (apply (lambda (syntmp-_-814 syntmp-name-815 syntmp-args-816 syntmp-e1-817 syntmp-e2-818) (values (quote define-form) (syntmp-wrap-143 syntmp-name-815 syntmp-w-788) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("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-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application 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) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-143 (cons syntmp-args-816 (cons syntmp-e1-817 syntmp-e2-818)) syntmp-w-788)) (quote (())) syntmp-s-789)) syntmp-tmp-808) ((lambda (syntmp-tmp-820) (if (if syntmp-tmp-820 (apply (lambda (syntmp-_-821 syntmp-name-822) (syntmp-id?-115 syntmp-name-822)) syntmp-tmp-820) #f) (apply (lambda (syntmp-_-823 syntmp-name-824) (values (quote define-form) (syntmp-wrap-143 syntmp-name-824 syntmp-w-788) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("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-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application 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) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-789)) syntmp-tmp-820) (syntax-error syntmp-tmp-800))) (syntax-dispatch syntmp-tmp-800 (quote (any any)))))) (syntax-dispatch syntmp-tmp-800 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-800 (quote (any any any))))) syntmp-e-786) (if (memv syntmp-t-799 (quote (define-syntax))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-115 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-syntax-form) syntmp-name-831 syntmp-val-832 syntmp-w-788 syntmp-s-789)) syntmp-tmp-826) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-786) (values (quote call) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)))))))))))))) (values (quote call) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)))) ((syntmp-syntax-object?-101 syntmp-e-786) (syntmp-syntax-type-149 (syntmp-syntax-object-expression-102 syntmp-e-786) syntmp-r-787 (syntmp-join-wraps-134 syntmp-w-788 (syntmp-syntax-object-wrap-103 syntmp-e-786)) #f syntmp-rib-790)) ((syntmp-annotation?-89 syntmp-e-786) (syntmp-syntax-type-149 (annotation-expression syntmp-e-786) syntmp-r-787 syntmp-w-788 (annotation-source syntmp-e-786) syntmp-rib-790)) ((self-evaluating? syntmp-e-786) (values (quote constant) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)) (else (values (quote other) #f syntmp-e-786 syntmp-w-788 syntmp-s-789))))) (syntmp-chi-when-list-148 (lambda (syntmp-e-833 syntmp-when-list-834 syntmp-w-835) (let syntmp-f-836 ((syntmp-when-list-837 syntmp-when-list-834) (syntmp-situations-838 (quote ()))) (if (null? syntmp-when-list-837) syntmp-situations-838 (syntmp-f-836 (cdr syntmp-when-list-837) (cons (let ((syntmp-x-839 (car syntmp-when-list-837))) (cond ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application 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) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application 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) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application 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) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-143 syntmp-x-839 syntmp-w-835) "invalid eval-when situation")))) syntmp-situations-838)))))) (syntmp-chi-install-global-147 (lambda (syntmp-name-840 syntmp-e-841) (list (quote install-global-transformer) (syntmp-build-data-95 #f syntmp-name-840) syntmp-e-841))) (syntmp-chi-top-sequence-146 (lambda (syntmp-body-842 syntmp-r-843 syntmp-w-844 syntmp-s-845 syntmp-m-846 syntmp-esew-847) (syntmp-build-sequence-96 syntmp-s-845 (let syntmp-dobody-848 ((syntmp-body-849 syntmp-body-842) (syntmp-r-850 syntmp-r-843) (syntmp-w-851 syntmp-w-844) (syntmp-m-852 syntmp-m-846) (syntmp-esew-853 syntmp-esew-847)) (if (null? syntmp-body-849) (quote ()) (let ((syntmp-first-854 (syntmp-chi-top-150 (car syntmp-body-849) syntmp-r-850 syntmp-w-851 syntmp-m-852 syntmp-esew-853))) (cons syntmp-first-854 (syntmp-dobody-848 (cdr syntmp-body-849) syntmp-r-850 syntmp-w-851 syntmp-m-852 syntmp-esew-853)))))))) (syntmp-chi-sequence-145 (lambda (syntmp-body-855 syntmp-r-856 syntmp-w-857 syntmp-s-858) (syntmp-build-sequence-96 syntmp-s-858 (let syntmp-dobody-859 ((syntmp-body-860 syntmp-body-855) (syntmp-r-861 syntmp-r-856) (syntmp-w-862 syntmp-w-857)) (if (null? syntmp-body-860) (quote ()) (let ((syntmp-first-863 (syntmp-chi-151 (car syntmp-body-860) syntmp-r-861 syntmp-w-862))) (cons syntmp-first-863 (syntmp-dobody-859 (cdr syntmp-body-860) syntmp-r-861 syntmp-w-862)))))))) (syntmp-source-wrap-144 (lambda (syntmp-x-864 syntmp-w-865 syntmp-s-866) (syntmp-wrap-143 (if syntmp-s-866 (make-annotation syntmp-x-864 syntmp-s-866 #f) syntmp-x-864) syntmp-w-865))) (syntmp-wrap-143 (lambda (syntmp-x-867 syntmp-w-868) (cond ((and (null? (syntmp-wrap-marks-118 syntmp-w-868)) (null? (syntmp-wrap-subst-119 syntmp-w-868))) syntmp-x-867) ((syntmp-syntax-object?-101 syntmp-x-867) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-867) (syntmp-join-wraps-134 syntmp-w-868 (syntmp-syntax-object-wrap-103 syntmp-x-867)))) ((null? syntmp-x-867) syntmp-x-867) (else (syntmp-make-syntax-object-100 syntmp-x-867 syntmp-w-868))))) (syntmp-bound-id-member?-142 (lambda (syntmp-x-869 syntmp-list-870) (and (not (null? syntmp-list-870)) (or (syntmp-bound-id=?-139 syntmp-x-869 (car syntmp-list-870)) (syntmp-bound-id-member?-142 syntmp-x-869 (cdr syntmp-list-870)))))) (syntmp-distinct-bound-ids?-141 (lambda (syntmp-ids-871) (let syntmp-distinct?-872 ((syntmp-ids-873 syntmp-ids-871)) (or (null? syntmp-ids-873) (and (not (syntmp-bound-id-member?-142 (car syntmp-ids-873) (cdr syntmp-ids-873))) (syntmp-distinct?-872 (cdr syntmp-ids-873))))))) (syntmp-valid-bound-ids?-140 (lambda (syntmp-ids-874) (and (let syntmp-all-ids?-875 ((syntmp-ids-876 syntmp-ids-874)) (or (null? syntmp-ids-876) (and (syntmp-id?-115 (car syntmp-ids-876)) (syntmp-all-ids?-875 (cdr syntmp-ids-876))))) (syntmp-distinct-bound-ids?-141 syntmp-ids-874)))) (syntmp-bound-id=?-139 (lambda (syntmp-i-877 syntmp-j-878) (if (and (syntmp-syntax-object?-101 syntmp-i-877) (syntmp-syntax-object?-101 syntmp-j-878)) (and (eq? (let ((syntmp-e-879 (syntmp-syntax-object-expression-102 syntmp-i-877))) (if (syntmp-annotation?-89 syntmp-e-879) (annotation-expression syntmp-e-879) syntmp-e-879)) (let ((syntmp-e-880 (syntmp-syntax-object-expression-102 syntmp-j-878))) (if (syntmp-annotation?-89 syntmp-e-880) (annotation-expression syntmp-e-880) syntmp-e-880))) (syntmp-same-marks?-136 (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-i-877)) (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-j-878)))) (eq? (let ((syntmp-e-881 syntmp-i-877)) (if (syntmp-annotation?-89 syntmp-e-881) (annotation-expression syntmp-e-881) syntmp-e-881)) (let ((syntmp-e-882 syntmp-j-878)) (if (syntmp-annotation?-89 syntmp-e-882) (annotation-expression syntmp-e-882) syntmp-e-882)))))) (syntmp-free-id=?-138 (lambda (syntmp-i-883 syntmp-j-884) (and (eq? (let ((syntmp-x-885 syntmp-i-883)) (let ((syntmp-e-886 (if (syntmp-syntax-object?-101 syntmp-x-885) (syntmp-syntax-object-expression-102 syntmp-x-885) syntmp-x-885))) (if (syntmp-annotation?-89 syntmp-e-886) (annotation-expression syntmp-e-886) syntmp-e-886))) (let ((syntmp-x-887 syntmp-j-884)) (let ((syntmp-e-888 (if (syntmp-syntax-object?-101 syntmp-x-887) (syntmp-syntax-object-expression-102 syntmp-x-887) syntmp-x-887))) (if (syntmp-annotation?-89 syntmp-e-888) (annotation-expression syntmp-e-888) syntmp-e-888)))) (eq? (syntmp-id-var-name-137 syntmp-i-883 (quote (()))) (syntmp-id-var-name-137 syntmp-j-884 (quote (()))))))) (syntmp-id-var-name-137 (lambda (syntmp-id-889 syntmp-w-890) (letrec ((syntmp-search-vector-rib-893 (lambda (syntmp-sym-904 syntmp-subst-905 syntmp-marks-906 syntmp-symnames-907 syntmp-ribcage-908) (let ((syntmp-n-909 (vector-length syntmp-symnames-907))) (let syntmp-f-910 ((syntmp-i-911 0)) (cond ((syntmp-fx=-87 syntmp-i-911 syntmp-n-909) (syntmp-search-891 syntmp-sym-904 (cdr syntmp-subst-905) syntmp-marks-906)) ((and (eq? (vector-ref syntmp-symnames-907 syntmp-i-911) syntmp-sym-904) (syntmp-same-marks?-136 syntmp-marks-906 (vector-ref (syntmp-ribcage-marks-125 syntmp-ribcage-908) syntmp-i-911))) (values (vector-ref (syntmp-ribcage-labels-126 syntmp-ribcage-908) syntmp-i-911) syntmp-marks-906)) (else (syntmp-f-910 (syntmp-fx+-85 syntmp-i-911 1)))))))) (syntmp-search-list-rib-892 (lambda (syntmp-sym-912 syntmp-subst-913 syntmp-marks-914 syntmp-symnames-915 syntmp-ribcage-916) (let syntmp-f-917 ((syntmp-symnames-918 syntmp-symnames-915) (syntmp-i-919 0)) (cond ((null? syntmp-symnames-918) (syntmp-search-891 syntmp-sym-912 (cdr syntmp-subst-913) syntmp-marks-914)) ((and (eq? (car syntmp-symnames-918) syntmp-sym-912) (syntmp-same-marks?-136 syntmp-marks-914 (list-ref (syntmp-ribcage-marks-125 syntmp-ribcage-916) syntmp-i-919))) (values (list-ref (syntmp-ribcage-labels-126 syntmp-ribcage-916) syntmp-i-919) syntmp-marks-914)) (else (syntmp-f-917 (cdr syntmp-symnames-918) (syntmp-fx+-85 syntmp-i-919 1))))))) (syntmp-search-891 (lambda (syntmp-sym-920 syntmp-subst-921 syntmp-marks-922) (if (null? syntmp-subst-921) (values #f syntmp-marks-922) (let ((syntmp-fst-923 (car syntmp-subst-921))) (if (eq? syntmp-fst-923 (quote shift)) (syntmp-search-891 syntmp-sym-920 (cdr syntmp-subst-921) (cdr syntmp-marks-922)) (let ((syntmp-symnames-924 (syntmp-ribcage-symnames-124 syntmp-fst-923))) (if (vector? syntmp-symnames-924) (syntmp-search-vector-rib-893 syntmp-sym-920 syntmp-subst-921 syntmp-marks-922 syntmp-symnames-924 syntmp-fst-923) (syntmp-search-list-rib-892 syntmp-sym-920 syntmp-subst-921 syntmp-marks-922 syntmp-symnames-924 syntmp-fst-923))))))))) (cond ((symbol? syntmp-id-889) (or (call-with-values (lambda () (syntmp-search-891 syntmp-id-889 (syntmp-wrap-subst-119 syntmp-w-890) (syntmp-wrap-marks-118 syntmp-w-890))) (lambda (syntmp-x-926 . syntmp-ignore-925) syntmp-x-926)) syntmp-id-889)) ((syntmp-syntax-object?-101 syntmp-id-889) (let ((syntmp-id-927 (let ((syntmp-e-929 (syntmp-syntax-object-expression-102 syntmp-id-889))) (if (syntmp-annotation?-89 syntmp-e-929) (annotation-expression syntmp-e-929) syntmp-e-929))) (syntmp-w1-928 (syntmp-syntax-object-wrap-103 syntmp-id-889))) (let ((syntmp-marks-930 (syntmp-join-marks-135 (syntmp-wrap-marks-118 syntmp-w-890) (syntmp-wrap-marks-118 syntmp-w1-928)))) (call-with-values (lambda () (syntmp-search-891 syntmp-id-927 (syntmp-wrap-subst-119 syntmp-w-890) syntmp-marks-930)) (lambda (syntmp-new-id-931 syntmp-marks-932) (or syntmp-new-id-931 (call-with-values (lambda () (syntmp-search-891 syntmp-id-927 (syntmp-wrap-subst-119 syntmp-w1-928) syntmp-marks-932)) (lambda (syntmp-x-934 . syntmp-ignore-933) syntmp-x-934)) syntmp-id-927)))))) ((syntmp-annotation?-89 syntmp-id-889) (let ((syntmp-id-935 (let ((syntmp-e-936 syntmp-id-889)) (if (syntmp-annotation?-89 syntmp-e-936) (annotation-expression syntmp-e-936) syntmp-e-936)))) (or (call-with-values (lambda () (syntmp-search-891 syntmp-id-935 (syntmp-wrap-subst-119 syntmp-w-890) (syntmp-wrap-marks-118 syntmp-w-890))) (lambda (syntmp-x-938 . syntmp-ignore-937) syntmp-x-938)) syntmp-id-935))) (else (syntmp-error-hook-92 (quote id-var-name) "invalid id" syntmp-id-889)))))) (syntmp-same-marks?-136 (lambda (syntmp-x-939 syntmp-y-940) (or (eq? syntmp-x-939 syntmp-y-940) (and (not (null? syntmp-x-939)) (not (null? syntmp-y-940)) (eq? (car syntmp-x-939) (car syntmp-y-940)) (syntmp-same-marks?-136 (cdr syntmp-x-939) (cdr syntmp-y-940)))))) (syntmp-join-marks-135 (lambda (syntmp-m1-941 syntmp-m2-942) (syntmp-smart-append-133 syntmp-m1-941 syntmp-m2-942))) (syntmp-join-wraps-134 (lambda (syntmp-w1-943 syntmp-w2-944) (let ((syntmp-m1-945 (syntmp-wrap-marks-118 syntmp-w1-943)) (syntmp-s1-946 (syntmp-wrap-subst-119 syntmp-w1-943))) (if (null? syntmp-m1-945) (if (null? syntmp-s1-946) syntmp-w2-944 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w2-944) (syntmp-smart-append-133 syntmp-s1-946 (syntmp-wrap-subst-119 syntmp-w2-944)))) (syntmp-make-wrap-117 (syntmp-smart-append-133 syntmp-m1-945 (syntmp-wrap-marks-118 syntmp-w2-944)) (syntmp-smart-append-133 syntmp-s1-946 (syntmp-wrap-subst-119 syntmp-w2-944))))))) (syntmp-smart-append-133 (lambda (syntmp-m1-947 syntmp-m2-948) (if (null? syntmp-m2-948) syntmp-m1-947 (append syntmp-m1-947 syntmp-m2-948)))) (syntmp-make-binding-wrap-132 (lambda (syntmp-ids-949 syntmp-labels-950 syntmp-w-951) (if (null? syntmp-ids-949) syntmp-w-951 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w-951) (cons (let ((syntmp-labelvec-952 (list->vector syntmp-labels-950))) (let ((syntmp-n-953 (vector-length syntmp-labelvec-952))) (let ((syntmp-symnamevec-954 (make-vector syntmp-n-953)) (syntmp-marksvec-955 (make-vector syntmp-n-953))) (begin (let syntmp-f-956 ((syntmp-ids-957 syntmp-ids-949) (syntmp-i-958 0)) (if (not (null? syntmp-ids-957)) (call-with-values (lambda () (syntmp-id-sym-name&marks-116 (car syntmp-ids-957) syntmp-w-951)) (lambda (syntmp-symname-959 syntmp-marks-960) (begin (vector-set! syntmp-symnamevec-954 syntmp-i-958 syntmp-symname-959) (vector-set! syntmp-marksvec-955 syntmp-i-958 syntmp-marks-960) (syntmp-f-956 (cdr syntmp-ids-957) (syntmp-fx+-85 syntmp-i-958 1))))))) (syntmp-make-ribcage-122 syntmp-symnamevec-954 syntmp-marksvec-955 syntmp-labelvec-952))))) (syntmp-wrap-subst-119 syntmp-w-951)))))) (syntmp-extend-ribcage!-131 (lambda (syntmp-ribcage-961 syntmp-id-962 syntmp-label-963) (begin (syntmp-set-ribcage-symnames!-127 syntmp-ribcage-961 (cons (let ((syntmp-e-964 (syntmp-syntax-object-expression-102 syntmp-id-962))) (if (syntmp-annotation?-89 syntmp-e-964) (annotation-expression syntmp-e-964) syntmp-e-964)) (syntmp-ribcage-symnames-124 syntmp-ribcage-961))) (syntmp-set-ribcage-marks!-128 syntmp-ribcage-961 (cons (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-id-962)) (syntmp-ribcage-marks-125 syntmp-ribcage-961))) (syntmp-set-ribcage-labels!-129 syntmp-ribcage-961 (cons syntmp-label-963 (syntmp-ribcage-labels-126 syntmp-ribcage-961)))))) (syntmp-anti-mark-130 (lambda (syntmp-w-965) (syntmp-make-wrap-117 (cons #f (syntmp-wrap-marks-118 syntmp-w-965)) (cons (quote shift) (syntmp-wrap-subst-119 syntmp-w-965))))) (syntmp-set-ribcage-labels!-129 (lambda (syntmp-x-966 syntmp-update-967) (vector-set! syntmp-x-966 3 syntmp-update-967))) (syntmp-set-ribcage-marks!-128 (lambda (syntmp-x-968 syntmp-update-969) (vector-set! syntmp-x-968 2 syntmp-update-969))) (syntmp-set-ribcage-symnames!-127 (lambda (syntmp-x-970 syntmp-update-971) (vector-set! syntmp-x-970 1 syntmp-update-971))) (syntmp-ribcage-labels-126 (lambda (syntmp-x-972) (vector-ref syntmp-x-972 3))) (syntmp-ribcage-marks-125 (lambda (syntmp-x-973) (vector-ref syntmp-x-973 2))) (syntmp-ribcage-symnames-124 (lambda (syntmp-x-974) (vector-ref syntmp-x-974 1))) (syntmp-ribcage?-123 (lambda (syntmp-x-975) (and (vector? syntmp-x-975) (= (vector-length syntmp-x-975) 4) (eq? (vector-ref syntmp-x-975 0) (quote ribcage))))) (syntmp-make-ribcage-122 (lambda (syntmp-symnames-976 syntmp-marks-977 syntmp-labels-978) (vector (quote ribcage) syntmp-symnames-976 syntmp-marks-977 syntmp-labels-978))) (syntmp-gen-labels-121 (lambda (syntmp-ls-979) (if (null? syntmp-ls-979) (quote ()) (cons (syntmp-gen-label-120) (syntmp-gen-labels-121 (cdr syntmp-ls-979)))))) (syntmp-gen-label-120 (lambda () (string #\i))) (syntmp-wrap-subst-119 cdr) (syntmp-wrap-marks-118 car) (syntmp-make-wrap-117 cons) (syntmp-id-sym-name&marks-116 (lambda (syntmp-x-980 syntmp-w-981) (if (syntmp-syntax-object?-101 syntmp-x-980) (values (let ((syntmp-e-982 (syntmp-syntax-object-expression-102 syntmp-x-980))) (if (syntmp-annotation?-89 syntmp-e-982) (annotation-expression syntmp-e-982) syntmp-e-982)) (syntmp-join-marks-135 (syntmp-wrap-marks-118 syntmp-w-981) (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-x-980)))) (values (let ((syntmp-e-983 syntmp-x-980)) (if (syntmp-annotation?-89 syntmp-e-983) (annotation-expression syntmp-e-983) syntmp-e-983)) (syntmp-wrap-marks-118 syntmp-w-981))))) (syntmp-id?-115 (lambda (syntmp-x-984) (cond ((symbol? syntmp-x-984) #t) ((syntmp-syntax-object?-101 syntmp-x-984) (symbol? (let ((syntmp-e-985 (syntmp-syntax-object-expression-102 syntmp-x-984))) (if (syntmp-annotation?-89 syntmp-e-985) (annotation-expression syntmp-e-985) syntmp-e-985)))) ((syntmp-annotation?-89 syntmp-x-984) (symbol? (annotation-expression syntmp-x-984))) (else #f)))) (syntmp-nonsymbol-id?-114 (lambda (syntmp-x-986) (and (syntmp-syntax-object?-101 syntmp-x-986) (symbol? (let ((syntmp-e-987 (syntmp-syntax-object-expression-102 syntmp-x-986))) (if (syntmp-annotation?-89 syntmp-e-987) (annotation-expression syntmp-e-987) syntmp-e-987)))))) (syntmp-global-extend-113 (lambda (syntmp-type-988 syntmp-sym-989 syntmp-val-990) (syntmp-put-global-definition-hook-93 syntmp-sym-989 (cons syntmp-type-988 syntmp-val-990)))) (syntmp-lookup-112 (lambda (syntmp-x-991 syntmp-r-992) (cond ((assq syntmp-x-991 syntmp-r-992) => cdr) ((symbol? syntmp-x-991) (or (syntmp-get-global-definition-hook-94 syntmp-x-991) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-111 (lambda (syntmp-r-993) (if (null? syntmp-r-993) (quote ()) (let ((syntmp-a-994 (car syntmp-r-993))) (if (eq? (cadr syntmp-a-994) (quote macro)) (cons syntmp-a-994 (syntmp-macros-only-env-111 (cdr syntmp-r-993))) (syntmp-macros-only-env-111 (cdr syntmp-r-993))))))) (syntmp-extend-var-env-110 (lambda (syntmp-labels-995 syntmp-vars-996 syntmp-r-997) (if (null? syntmp-labels-995) syntmp-r-997 (syntmp-extend-var-env-110 (cdr syntmp-labels-995) (cdr syntmp-vars-996) (cons (cons (car syntmp-labels-995) (cons (quote lexical) (car syntmp-vars-996))) syntmp-r-997))))) (syntmp-extend-env-109 (lambda (syntmp-labels-998 syntmp-bindings-999 syntmp-r-1000) (if (null? syntmp-labels-998) syntmp-r-1000 (syntmp-extend-env-109 (cdr syntmp-labels-998) (cdr syntmp-bindings-999) (cons (cons (car syntmp-labels-998) (car syntmp-bindings-999)) syntmp-r-1000))))) (syntmp-binding-value-108 cdr) (syntmp-binding-type-107 car) (syntmp-source-annotation-106 (lambda (syntmp-x-1001) (cond ((syntmp-annotation?-89 syntmp-x-1001) (annotation-source syntmp-x-1001)) ((syntmp-syntax-object?-101 syntmp-x-1001) (syntmp-source-annotation-106 (syntmp-syntax-object-expression-102 syntmp-x-1001))) (else #f)))) (syntmp-set-syntax-object-wrap!-105 (lambda (syntmp-x-1002 syntmp-update-1003) (vector-set! syntmp-x-1002 2 syntmp-update-1003))) (syntmp-set-syntax-object-expression!-104 (lambda (syntmp-x-1004 syntmp-update-1005) (vector-set! syntmp-x-1004 1 syntmp-update-1005))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1006) (vector-ref syntmp-x-1006 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1007) (vector-ref syntmp-x-1007 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1008) (and (vector? syntmp-x-1008) (= (vector-length syntmp-x-1008) 3) (eq? (vector-ref syntmp-x-1008 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1009 syntmp-wrap-1010) (vector (quote syntax-object) syntmp-expression-1009 syntmp-wrap-1010))) (syntmp-build-letrec-99 (lambda (syntmp-src-1011 syntmp-vars-1012 syntmp-val-exps-1013 syntmp-body-exp-1014) (if (null? syntmp-vars-1012) syntmp-body-exp-1014 (list (quote letrec) (map list syntmp-vars-1012 syntmp-val-exps-1013) syntmp-body-exp-1014)))) (syntmp-build-named-let-98 (lambda (syntmp-src-1015 syntmp-vars-1016 syntmp-val-exps-1017 syntmp-body-exp-1018) (if (null? syntmp-vars-1016) syntmp-body-exp-1018 (list (quote let) (car syntmp-vars-1016) (map list (cdr syntmp-vars-1016) syntmp-val-exps-1017) syntmp-body-exp-1018)))) (syntmp-build-let-97 (lambda (syntmp-src-1019 syntmp-vars-1020 syntmp-val-exps-1021 syntmp-body-exp-1022) (if (null? syntmp-vars-1020) syntmp-body-exp-1022 (list (quote let) (map list syntmp-vars-1020 syntmp-val-exps-1021) syntmp-body-exp-1022)))) (syntmp-build-sequence-96 (lambda (syntmp-src-1023 syntmp-exps-1024) (if (null? (cdr syntmp-exps-1024)) (car syntmp-exps-1024) (cons (quote begin) syntmp-exps-1024)))) (syntmp-build-data-95 (lambda (syntmp-src-1025 syntmp-exp-1026) (if (and (self-evaluating? syntmp-exp-1026) (not (vector? syntmp-exp-1026))) syntmp-exp-1026 (list (quote quote) syntmp-exp-1026)))) (syntmp-get-global-definition-hook-94 (lambda (syntmp-symbol-1027) (getprop syntmp-symbol-1027 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-93 (lambda (syntmp-symbol-1028 syntmp-binding-1029) (putprop syntmp-symbol-1028 (quote *sc-expander*) syntmp-binding-1029))) (syntmp-error-hook-92 (lambda (syntmp-who-1030 syntmp-why-1031 syntmp-what-1032) (error syntmp-who-1030 "~a ~s" syntmp-why-1031 syntmp-what-1032))) (syntmp-local-eval-hook-91 (lambda (syntmp-x-1033) (eval (list syntmp-noexpand-84 syntmp-x-1033) (interaction-environment)))) (syntmp-top-level-eval-hook-90 (lambda (syntmp-x-1034) (eval (list syntmp-noexpand-84 syntmp-x-1034) (interaction-environment)))) (syntmp-annotation?-89 (lambda (syntmp-x-1035) #f)) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-113 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-113 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-113 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1036 syntmp-r-1037 syntmp-w-1038 syntmp-s-1039) ((lambda (syntmp-tmp-1040) ((lambda (syntmp-tmp-1041) (if (if syntmp-tmp-1041 (apply (lambda (syntmp-_-1042 syntmp-var-1043 syntmp-val-1044 syntmp-e1-1045 syntmp-e2-1046) (syntmp-valid-bound-ids?-140 syntmp-var-1043)) syntmp-tmp-1041) #f) (apply (lambda (syntmp-_-1048 syntmp-var-1049 syntmp-val-1050 syntmp-e1-1051 syntmp-e2-1052) (let ((syntmp-names-1053 (map (lambda (syntmp-x-1054) (syntmp-id-var-name-137 syntmp-x-1054 syntmp-w-1038)) syntmp-var-1049))) (begin (for-each (lambda (syntmp-id-1056 syntmp-n-1057) (let ((syntmp-t-1058 (syntmp-binding-type-107 (syntmp-lookup-112 syntmp-n-1057 syntmp-r-1037)))) (if (memv syntmp-t-1058 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-144 syntmp-id-1056 syntmp-w-1038 syntmp-s-1039) "identifier out of context")))) syntmp-var-1049 syntmp-names-1053) (syntmp-chi-body-155 (cons syntmp-e1-1051 syntmp-e2-1052) (syntmp-source-wrap-144 syntmp-e-1036 syntmp-w-1038 syntmp-s-1039) (syntmp-extend-env-109 syntmp-names-1053 (let ((syntmp-trans-r-1061 (syntmp-macros-only-env-111 syntmp-r-1037))) (map (lambda (syntmp-x-1062) (cons (quote macro) (syntmp-eval-local-transformer-158 (syntmp-chi-151 syntmp-x-1062 syntmp-trans-r-1061 syntmp-w-1038)))) syntmp-val-1050)) syntmp-r-1037) syntmp-w-1038)))) syntmp-tmp-1041) ((lambda (syntmp-_-1064) (syntax-error (syntmp-source-wrap-144 syntmp-e-1036 syntmp-w-1038 syntmp-s-1039))) syntmp-tmp-1040))) (syntax-dispatch syntmp-tmp-1040 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1036))) (syntmp-global-extend-113 (quote core) (quote quote) (lambda (syntmp-e-1065 syntmp-r-1066 syntmp-w-1067 syntmp-s-1068) ((lambda (syntmp-tmp-1069) ((lambda (syntmp-tmp-1070) (if syntmp-tmp-1070 (apply (lambda (syntmp-_-1071 syntmp-e-1072) (syntmp-build-data-95 syntmp-s-1068 (syntmp-strip-162 syntmp-e-1072 syntmp-w-1067))) syntmp-tmp-1070) ((lambda (syntmp-_-1073) (syntax-error (syntmp-source-wrap-144 syntmp-e-1065 syntmp-w-1067 syntmp-s-1068))) syntmp-tmp-1069))) (syntax-dispatch syntmp-tmp-1069 (quote (any any))))) syntmp-e-1065))) (syntmp-global-extend-113 (quote core) (quote syntax) (letrec ((syntmp-regen-1081 (lambda (syntmp-x-1082) (let ((syntmp-t-1083 (car syntmp-x-1082))) (if (memv syntmp-t-1083 (quote (ref))) (cadr syntmp-x-1082) (if (memv syntmp-t-1083 (quote (primitive))) (cadr syntmp-x-1082) (if (memv syntmp-t-1083 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1082)) (if (memv syntmp-t-1083 (quote (lambda))) (list (quote lambda) (cadr syntmp-x-1082) (syntmp-regen-1081 (caddr syntmp-x-1082))) (if (memv syntmp-t-1083 (quote (map))) (let ((syntmp-ls-1084 (map syntmp-regen-1081 (cdr syntmp-x-1082)))) (cons (if (syntmp-fx=-87 (length syntmp-ls-1084) 2) (quote map) (quote map)) syntmp-ls-1084)) (cons (car syntmp-x-1082) (map syntmp-regen-1081 (cdr syntmp-x-1082))))))))))) (syntmp-gen-vector-1080 (lambda (syntmp-x-1085) (cond ((eq? (car syntmp-x-1085) (quote list)) (cons (quote vector) (cdr syntmp-x-1085))) ((eq? (car syntmp-x-1085) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1085)))) (else (list (quote list->vector) syntmp-x-1085))))) (syntmp-gen-append-1079 (lambda (syntmp-x-1086 syntmp-y-1087) (if (equal? syntmp-y-1087 (quote (quote ()))) syntmp-x-1086 (list (quote append) syntmp-x-1086 syntmp-y-1087)))) (syntmp-gen-cons-1078 (lambda (syntmp-x-1088 syntmp-y-1089) (let ((syntmp-t-1090 (car syntmp-y-1089))) (if (memv syntmp-t-1090 (quote (quote))) (if (eq? (car syntmp-x-1088) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1088) (cadr syntmp-y-1089))) (if (eq? (cadr syntmp-y-1089) (quote ())) (list (quote list) syntmp-x-1088) (list (quote cons) syntmp-x-1088 syntmp-y-1089))) (if (memv syntmp-t-1090 (quote (list))) (cons (quote list) (cons syntmp-x-1088 (cdr syntmp-y-1089))) (list (quote cons) syntmp-x-1088 syntmp-y-1089)))))) (syntmp-gen-map-1077 (lambda (syntmp-e-1091 syntmp-map-env-1092) (let ((syntmp-formals-1093 (map cdr syntmp-map-env-1092)) (syntmp-actuals-1094 (map (lambda (syntmp-x-1095) (list (quote ref) (car syntmp-x-1095))) syntmp-map-env-1092))) (cond ((eq? (car syntmp-e-1091) (quote ref)) (car syntmp-actuals-1094)) ((andmap (lambda (syntmp-x-1096) (and (eq? (car syntmp-x-1096) (quote ref)) (memq (cadr syntmp-x-1096) syntmp-formals-1093))) (cdr syntmp-e-1091)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1091)) (map (let ((syntmp-r-1097 (map cons syntmp-formals-1093 syntmp-actuals-1094))) (lambda (syntmp-x-1098) (cdr (assq (cadr syntmp-x-1098) syntmp-r-1097)))) (cdr syntmp-e-1091))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1093 syntmp-e-1091) syntmp-actuals-1094))))))) (syntmp-gen-mappend-1076 (lambda (syntmp-e-1099 syntmp-map-env-1100) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1077 syntmp-e-1099 syntmp-map-env-1100)))) (syntmp-gen-ref-1075 (lambda (syntmp-src-1101 syntmp-var-1102 syntmp-level-1103 syntmp-maps-1104) (if (syntmp-fx=-87 syntmp-level-1103 0) (values syntmp-var-1102 syntmp-maps-1104) (if (null? syntmp-maps-1104) (syntax-error syntmp-src-1101 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1075 syntmp-src-1101 syntmp-var-1102 (syntmp-fx--86 syntmp-level-1103 1) (cdr syntmp-maps-1104))) (lambda (syntmp-outer-var-1105 syntmp-outer-maps-1106) (let ((syntmp-b-1107 (assq syntmp-outer-var-1105 (car syntmp-maps-1104)))) (if syntmp-b-1107 (values (cdr syntmp-b-1107) syntmp-maps-1104) (let ((syntmp-inner-var-1108 (syntmp-gen-var-163 (quote tmp)))) (values syntmp-inner-var-1108 (cons (cons (cons syntmp-outer-var-1105 syntmp-inner-var-1108) (car syntmp-maps-1104)) syntmp-outer-maps-1106))))))))))) (syntmp-gen-syntax-1074 (lambda (syntmp-src-1109 syntmp-e-1110 syntmp-r-1111 syntmp-maps-1112 syntmp-ellipsis?-1113) (if (syntmp-id?-115 syntmp-e-1110) (let ((syntmp-label-1114 (syntmp-id-var-name-137 syntmp-e-1110 (quote (()))))) (let ((syntmp-b-1115 (syntmp-lookup-112 syntmp-label-1114 syntmp-r-1111))) (if (eq? (syntmp-binding-type-107 syntmp-b-1115) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1116 (syntmp-binding-value-108 syntmp-b-1115))) (syntmp-gen-ref-1075 syntmp-src-1109 (car syntmp-var.lev-1116) (cdr syntmp-var.lev-1116) syntmp-maps-1112))) (lambda (syntmp-var-1117 syntmp-maps-1118) (values (list (quote ref) syntmp-var-1117) syntmp-maps-1118))) (if (syntmp-ellipsis?-1113 syntmp-e-1110) (syntax-error syntmp-src-1109 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1110) syntmp-maps-1112))))) ((lambda (syntmp-tmp-1119) ((lambda (syntmp-tmp-1120) (if (if syntmp-tmp-1120 (apply (lambda (syntmp-dots-1121 syntmp-e-1122) (syntmp-ellipsis?-1113 syntmp-dots-1121)) syntmp-tmp-1120) #f) (apply (lambda (syntmp-dots-1123 syntmp-e-1124) (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-e-1124 syntmp-r-1111 syntmp-maps-1112 (lambda (syntmp-x-1125) #f))) syntmp-tmp-1120) ((lambda (syntmp-tmp-1126) (if (if syntmp-tmp-1126 (apply (lambda (syntmp-x-1127 syntmp-dots-1128 syntmp-y-1129) (syntmp-ellipsis?-1113 syntmp-dots-1128)) syntmp-tmp-1126) #f) (apply (lambda (syntmp-x-1130 syntmp-dots-1131 syntmp-y-1132) (let syntmp-f-1133 ((syntmp-y-1134 syntmp-y-1132) (syntmp-k-1135 (lambda (syntmp-maps-1136) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-x-1130 syntmp-r-1111 (cons (quote ()) syntmp-maps-1136) syntmp-ellipsis?-1113)) (lambda (syntmp-x-1137 syntmp-maps-1138) (if (null? (car syntmp-maps-1138)) (syntax-error syntmp-src-1109 "extra ellipsis in syntax form") (values (syntmp-gen-map-1077 syntmp-x-1137 (car syntmp-maps-1138)) (cdr syntmp-maps-1138)))))))) ((lambda (syntmp-tmp-1139) ((lambda (syntmp-tmp-1140) (if (if syntmp-tmp-1140 (apply (lambda (syntmp-dots-1141 syntmp-y-1142) (syntmp-ellipsis?-1113 syntmp-dots-1141)) syntmp-tmp-1140) #f) (apply (lambda (syntmp-dots-1143 syntmp-y-1144) (syntmp-f-1133 syntmp-y-1144 (lambda (syntmp-maps-1145) (call-with-values (lambda () (syntmp-k-1135 (cons (quote ()) syntmp-maps-1145))) (lambda (syntmp-x-1146 syntmp-maps-1147) (if (null? (car syntmp-maps-1147)) (syntax-error syntmp-src-1109 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1076 syntmp-x-1146 (car syntmp-maps-1147)) (cdr syntmp-maps-1147)))))))) syntmp-tmp-1140) ((lambda (syntmp-_-1148) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-y-1134 syntmp-r-1111 syntmp-maps-1112 syntmp-ellipsis?-1113)) (lambda (syntmp-y-1149 syntmp-maps-1150) (call-with-values (lambda () (syntmp-k-1135 syntmp-maps-1150)) (lambda (syntmp-x-1151 syntmp-maps-1152) (values (syntmp-gen-append-1079 syntmp-x-1151 syntmp-y-1149) syntmp-maps-1152)))))) syntmp-tmp-1139))) (syntax-dispatch syntmp-tmp-1139 (quote (any . any))))) syntmp-y-1134))) syntmp-tmp-1126) ((lambda (syntmp-tmp-1153) (if syntmp-tmp-1153 (apply (lambda (syntmp-x-1154 syntmp-y-1155) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-x-1154 syntmp-r-1111 syntmp-maps-1112 syntmp-ellipsis?-1113)) (lambda (syntmp-x-1156 syntmp-maps-1157) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-y-1155 syntmp-r-1111 syntmp-maps-1157 syntmp-ellipsis?-1113)) (lambda (syntmp-y-1158 syntmp-maps-1159) (values (syntmp-gen-cons-1078 syntmp-x-1156 syntmp-y-1158) syntmp-maps-1159)))))) syntmp-tmp-1153) ((lambda (syntmp-tmp-1160) (if syntmp-tmp-1160 (apply (lambda (syntmp-e1-1161 syntmp-e2-1162) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 (cons syntmp-e1-1161 syntmp-e2-1162) syntmp-r-1111 syntmp-maps-1112 syntmp-ellipsis?-1113)) (lambda (syntmp-e-1164 syntmp-maps-1165) (values (syntmp-gen-vector-1080 syntmp-e-1164) syntmp-maps-1165)))) syntmp-tmp-1160) ((lambda (syntmp-_-1166) (values (list (quote quote) syntmp-e-1110) syntmp-maps-1112)) syntmp-tmp-1119))) (syntax-dispatch syntmp-tmp-1119 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1119 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1119 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1119 (quote (any any))))) syntmp-e-1110))))) (lambda (syntmp-e-1167 syntmp-r-1168 syntmp-w-1169 syntmp-s-1170) (let ((syntmp-e-1171 (syntmp-source-wrap-144 syntmp-e-1167 syntmp-w-1169 syntmp-s-1170))) ((lambda (syntmp-tmp-1172) ((lambda (syntmp-tmp-1173) (if syntmp-tmp-1173 (apply (lambda (syntmp-_-1174 syntmp-x-1175) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-e-1171 syntmp-x-1175 syntmp-r-1168 (quote ()) syntmp-ellipsis?-160)) (lambda (syntmp-e-1176 syntmp-maps-1177) (syntmp-regen-1081 syntmp-e-1176)))) syntmp-tmp-1173) ((lambda (syntmp-_-1178) (syntax-error syntmp-e-1171)) syntmp-tmp-1172))) (syntax-dispatch syntmp-tmp-1172 (quote (any any))))) syntmp-e-1171))))) (syntmp-global-extend-113 (quote core) (quote lambda) (lambda (syntmp-e-1179 syntmp-r-1180 syntmp-w-1181 syntmp-s-1182) ((lambda (syntmp-tmp-1183) ((lambda (syntmp-tmp-1184) (if syntmp-tmp-1184 (apply (lambda (syntmp-_-1185 syntmp-c-1186) (syntmp-chi-lambda-clause-156 (syntmp-source-wrap-144 syntmp-e-1179 syntmp-w-1181 syntmp-s-1182) syntmp-c-1186 syntmp-r-1180 syntmp-w-1181 (lambda (syntmp-vars-1187 syntmp-body-1188) (list (quote lambda) syntmp-vars-1187 syntmp-body-1188)))) syntmp-tmp-1184) (syntax-error syntmp-tmp-1183))) (syntax-dispatch syntmp-tmp-1183 (quote (any . any))))) syntmp-e-1179))) (syntmp-global-extend-113 (quote core) (quote let) (letrec ((syntmp-chi-let-1189 (lambda (syntmp-e-1190 syntmp-r-1191 syntmp-w-1192 syntmp-s-1193 syntmp-constructor-1194 syntmp-ids-1195 syntmp-vals-1196 syntmp-exps-1197) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-1195)) (syntax-error syntmp-e-1190 "duplicate bound variable in") (let ((syntmp-labels-1198 (syntmp-gen-labels-121 syntmp-ids-1195)) (syntmp-new-vars-1199 (map syntmp-gen-var-163 syntmp-ids-1195))) (let ((syntmp-nw-1200 (syntmp-make-binding-wrap-132 syntmp-ids-1195 syntmp-labels-1198 syntmp-w-1192)) (syntmp-nr-1201 (syntmp-extend-var-env-110 syntmp-labels-1198 syntmp-new-vars-1199 syntmp-r-1191))) (syntmp-constructor-1194 syntmp-s-1193 syntmp-new-vars-1199 (map (lambda (syntmp-x-1202) (syntmp-chi-151 syntmp-x-1202 syntmp-r-1191 syntmp-w-1192)) syntmp-vals-1196) (syntmp-chi-body-155 syntmp-exps-1197 (syntmp-source-wrap-144 syntmp-e-1190 syntmp-nw-1200 syntmp-s-1193) syntmp-nr-1201 syntmp-nw-1200)))))))) (lambda (syntmp-e-1203 syntmp-r-1204 syntmp-w-1205 syntmp-s-1206) ((lambda (syntmp-tmp-1207) ((lambda (syntmp-tmp-1208) (if syntmp-tmp-1208 (apply (lambda (syntmp-_-1209 syntmp-id-1210 syntmp-val-1211 syntmp-e1-1212 syntmp-e2-1213) (syntmp-chi-let-1189 syntmp-e-1203 syntmp-r-1204 syntmp-w-1205 syntmp-s-1206 syntmp-build-let-97 syntmp-id-1210 syntmp-val-1211 (cons syntmp-e1-1212 syntmp-e2-1213))) syntmp-tmp-1208) ((lambda (syntmp-tmp-1217) (if (if syntmp-tmp-1217 (apply (lambda (syntmp-_-1218 syntmp-f-1219 syntmp-id-1220 syntmp-val-1221 syntmp-e1-1222 syntmp-e2-1223) (syntmp-id?-115 syntmp-f-1219)) syntmp-tmp-1217) #f) (apply (lambda (syntmp-_-1224 syntmp-f-1225 syntmp-id-1226 syntmp-val-1227 syntmp-e1-1228 syntmp-e2-1229) (syntmp-chi-let-1189 syntmp-e-1203 syntmp-r-1204 syntmp-w-1205 syntmp-s-1206 syntmp-build-named-let-98 (cons syntmp-f-1225 syntmp-id-1226) syntmp-val-1227 (cons syntmp-e1-1228 syntmp-e2-1229))) syntmp-tmp-1217) ((lambda (syntmp-_-1233) (syntax-error (syntmp-source-wrap-144 syntmp-e-1203 syntmp-w-1205 syntmp-s-1206))) syntmp-tmp-1207))) (syntax-dispatch syntmp-tmp-1207 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1207 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1203)))) (syntmp-global-extend-113 (quote core) (quote letrec) (lambda (syntmp-e-1234 syntmp-r-1235 syntmp-w-1236 syntmp-s-1237) ((lambda (syntmp-tmp-1238) ((lambda (syntmp-tmp-1239) (if syntmp-tmp-1239 (apply (lambda (syntmp-_-1240 syntmp-id-1241 syntmp-val-1242 syntmp-e1-1243 syntmp-e2-1244) (let ((syntmp-ids-1245 syntmp-id-1241)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-1245)) (syntax-error syntmp-e-1234 "duplicate bound variable in") (let ((syntmp-labels-1247 (syntmp-gen-labels-121 syntmp-ids-1245)) (syntmp-new-vars-1248 (map syntmp-gen-var-163 syntmp-ids-1245))) (let ((syntmp-w-1249 (syntmp-make-binding-wrap-132 syntmp-ids-1245 syntmp-labels-1247 syntmp-w-1236)) (syntmp-r-1250 (syntmp-extend-var-env-110 syntmp-labels-1247 syntmp-new-vars-1248 syntmp-r-1235))) (syntmp-build-letrec-99 syntmp-s-1237 syntmp-new-vars-1248 (map (lambda (syntmp-x-1251) (syntmp-chi-151 syntmp-x-1251 syntmp-r-1250 syntmp-w-1249)) syntmp-val-1242) (syntmp-chi-body-155 (cons syntmp-e1-1243 syntmp-e2-1244) (syntmp-source-wrap-144 syntmp-e-1234 syntmp-w-1249 syntmp-s-1237) syntmp-r-1250 syntmp-w-1249))))))) syntmp-tmp-1239) ((lambda (syntmp-_-1254) (syntax-error (syntmp-source-wrap-144 syntmp-e-1234 syntmp-w-1236 syntmp-s-1237))) syntmp-tmp-1238))) (syntax-dispatch syntmp-tmp-1238 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1234))) (syntmp-global-extend-113 (quote core) (quote set!) (lambda (syntmp-e-1255 syntmp-r-1256 syntmp-w-1257 syntmp-s-1258) ((lambda (syntmp-tmp-1259) ((lambda (syntmp-tmp-1260) (if (if syntmp-tmp-1260 (apply (lambda (syntmp-_-1261 syntmp-id-1262 syntmp-val-1263) (syntmp-id?-115 syntmp-id-1262)) syntmp-tmp-1260) #f) (apply (lambda (syntmp-_-1264 syntmp-id-1265 syntmp-val-1266) (let ((syntmp-val-1267 (syntmp-chi-151 syntmp-val-1266 syntmp-r-1256 syntmp-w-1257)) (syntmp-n-1268 (syntmp-id-var-name-137 syntmp-id-1265 syntmp-w-1257))) (let ((syntmp-b-1269 (syntmp-lookup-112 syntmp-n-1268 syntmp-r-1256))) (let ((syntmp-t-1270 (syntmp-binding-type-107 syntmp-b-1269))) (if (memv syntmp-t-1270 (quote (lexical))) (list (quote set!) (syntmp-binding-value-108 syntmp-b-1269) syntmp-val-1267) (if (memv syntmp-t-1270 (quote (global))) (list (quote set!) syntmp-n-1268 syntmp-val-1267) (if (memv syntmp-t-1270 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-143 syntmp-id-1265 syntmp-w-1257) "identifier out of context") (syntax-error (syntmp-source-wrap-144 syntmp-e-1255 syntmp-w-1257 syntmp-s-1258))))))))) syntmp-tmp-1260) ((lambda (syntmp-tmp-1271) (if syntmp-tmp-1271 (apply (lambda (syntmp-_-1272 syntmp-getter-1273 syntmp-arg-1274 syntmp-val-1275) (cons (syntmp-chi-151 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application 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) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1273) syntmp-r-1256 syntmp-w-1257) (map (lambda (syntmp-e-1276) (syntmp-chi-151 syntmp-e-1276 syntmp-r-1256 syntmp-w-1257)) (append syntmp-arg-1274 (list syntmp-val-1275))))) syntmp-tmp-1271) ((lambda (syntmp-_-1278) (syntax-error (syntmp-source-wrap-144 syntmp-e-1255 syntmp-w-1257 syntmp-s-1258))) syntmp-tmp-1259))) (syntax-dispatch syntmp-tmp-1259 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1259 (quote (any any any))))) syntmp-e-1255))) (syntmp-global-extend-113 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-113 (quote define) (quote define) (quote ())) (syntmp-global-extend-113 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-113 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-113 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1282 (lambda (syntmp-x-1283 syntmp-keys-1284 syntmp-clauses-1285 syntmp-r-1286) (if (null? syntmp-clauses-1285) (list (quote syntax-error) syntmp-x-1283) ((lambda (syntmp-tmp-1287) ((lambda (syntmp-tmp-1288) (if syntmp-tmp-1288 (apply (lambda (syntmp-pat-1289 syntmp-exp-1290) (if (and (syntmp-id?-115 syntmp-pat-1289) (andmap (lambda (syntmp-x-1291) (not (syntmp-free-id=?-138 syntmp-pat-1289 syntmp-x-1291))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application 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) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1284))) (let ((syntmp-labels-1292 (list (syntmp-gen-label-120))) (syntmp-var-1293 (syntmp-gen-var-163 syntmp-pat-1289))) (list (list (quote lambda) (list syntmp-var-1293) (syntmp-chi-151 syntmp-exp-1290 (syntmp-extend-env-109 syntmp-labels-1292 (list (cons (quote syntax) (cons syntmp-var-1293 0))) syntmp-r-1286) (syntmp-make-binding-wrap-132 (list syntmp-pat-1289) syntmp-labels-1292 (quote (()))))) syntmp-x-1283)) (syntmp-gen-clause-1281 syntmp-x-1283 syntmp-keys-1284 (cdr syntmp-clauses-1285) syntmp-r-1286 syntmp-pat-1289 #t syntmp-exp-1290))) syntmp-tmp-1288) ((lambda (syntmp-tmp-1294) (if syntmp-tmp-1294 (apply (lambda (syntmp-pat-1295 syntmp-fender-1296 syntmp-exp-1297) (syntmp-gen-clause-1281 syntmp-x-1283 syntmp-keys-1284 (cdr syntmp-clauses-1285) syntmp-r-1286 syntmp-pat-1295 syntmp-fender-1296 syntmp-exp-1297)) syntmp-tmp-1294) ((lambda (syntmp-_-1298) (syntax-error (car syntmp-clauses-1285) "invalid syntax-case clause")) syntmp-tmp-1287))) (syntax-dispatch syntmp-tmp-1287 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1287 (quote (any any))))) (car syntmp-clauses-1285))))) (syntmp-gen-clause-1281 (lambda (syntmp-x-1299 syntmp-keys-1300 syntmp-clauses-1301 syntmp-r-1302 syntmp-pat-1303 syntmp-fender-1304 syntmp-exp-1305) (call-with-values (lambda () (syntmp-convert-pattern-1279 syntmp-pat-1303 syntmp-keys-1300)) (lambda (syntmp-p-1306 syntmp-pvars-1307) (cond ((not (syntmp-distinct-bound-ids?-141 (map car syntmp-pvars-1307))) (syntax-error syntmp-pat-1303 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1308) (not (syntmp-ellipsis?-160 (car syntmp-x-1308)))) syntmp-pvars-1307)) (syntax-error syntmp-pat-1303 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1309 (syntmp-gen-var-163 (quote tmp)))) (list (list (quote lambda) (list syntmp-y-1309) (let ((syntmp-y-1310 syntmp-y-1309)) (list (quote if) ((lambda (syntmp-tmp-1311) ((lambda (syntmp-tmp-1312) (if syntmp-tmp-1312 (apply (lambda () syntmp-y-1310) syntmp-tmp-1312) ((lambda (syntmp-_-1313) (list (quote if) syntmp-y-1310 (syntmp-build-dispatch-call-1280 syntmp-pvars-1307 syntmp-fender-1304 syntmp-y-1310 syntmp-r-1302) (syntmp-build-data-95 #f #f))) syntmp-tmp-1311))) (syntax-dispatch syntmp-tmp-1311 (quote #(atom #t))))) syntmp-fender-1304) (syntmp-build-dispatch-call-1280 syntmp-pvars-1307 syntmp-exp-1305 syntmp-y-1310 syntmp-r-1302) (syntmp-gen-syntax-case-1282 syntmp-x-1299 syntmp-keys-1300 syntmp-clauses-1301 syntmp-r-1302)))) (if (eq? syntmp-p-1306 (quote any)) (list (quote list) syntmp-x-1299) (list (quote syntax-dispatch) syntmp-x-1299 (syntmp-build-data-95 #f syntmp-p-1306))))))))))) (syntmp-build-dispatch-call-1280 (lambda (syntmp-pvars-1314 syntmp-exp-1315 syntmp-y-1316 syntmp-r-1317) (let ((syntmp-ids-1318 (map car syntmp-pvars-1314)) (syntmp-levels-1319 (map cdr syntmp-pvars-1314))) (let ((syntmp-labels-1320 (syntmp-gen-labels-121 syntmp-ids-1318)) (syntmp-new-vars-1321 (map syntmp-gen-var-163 syntmp-ids-1318))) (list (quote apply) (list (quote lambda) syntmp-new-vars-1321 (syntmp-chi-151 syntmp-exp-1315 (syntmp-extend-env-109 syntmp-labels-1320 (map (lambda (syntmp-var-1322 syntmp-level-1323) (cons (quote syntax) (cons syntmp-var-1322 syntmp-level-1323))) syntmp-new-vars-1321 (map cdr syntmp-pvars-1314)) syntmp-r-1317) (syntmp-make-binding-wrap-132 syntmp-ids-1318 syntmp-labels-1320 (quote (()))))) syntmp-y-1316))))) (syntmp-convert-pattern-1279 (lambda (syntmp-pattern-1324 syntmp-keys-1325) (let syntmp-cvt-1326 ((syntmp-p-1327 syntmp-pattern-1324) (syntmp-n-1328 0) (syntmp-ids-1329 (quote ()))) (if (syntmp-id?-115 syntmp-p-1327) (if (syntmp-bound-id-member?-142 syntmp-p-1327 syntmp-keys-1325) (values (vector (quote free-id) syntmp-p-1327) syntmp-ids-1329) (values (quote any) (cons (cons syntmp-p-1327 syntmp-n-1328) syntmp-ids-1329))) ((lambda (syntmp-tmp-1330) ((lambda (syntmp-tmp-1331) (if (if syntmp-tmp-1331 (apply (lambda (syntmp-x-1332 syntmp-dots-1333) (syntmp-ellipsis?-160 syntmp-dots-1333)) syntmp-tmp-1331) #f) (apply (lambda (syntmp-x-1334 syntmp-dots-1335) (call-with-values (lambda () (syntmp-cvt-1326 syntmp-x-1334 (syntmp-fx+-85 syntmp-n-1328 1) syntmp-ids-1329)) (lambda (syntmp-p-1336 syntmp-ids-1337) (values (if (eq? syntmp-p-1336 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1336)) syntmp-ids-1337)))) syntmp-tmp-1331) ((lambda (syntmp-tmp-1338) (if syntmp-tmp-1338 (apply (lambda (syntmp-x-1339 syntmp-y-1340) (call-with-values (lambda () (syntmp-cvt-1326 syntmp-y-1340 syntmp-n-1328 syntmp-ids-1329)) (lambda (syntmp-y-1341 syntmp-ids-1342) (call-with-values (lambda () (syntmp-cvt-1326 syntmp-x-1339 syntmp-n-1328 syntmp-ids-1342)) (lambda (syntmp-x-1343 syntmp-ids-1344) (values (cons syntmp-x-1343 syntmp-y-1341) syntmp-ids-1344)))))) syntmp-tmp-1338) ((lambda (syntmp-tmp-1345) (if syntmp-tmp-1345 (apply (lambda () (values (quote ()) syntmp-ids-1329)) syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if syntmp-tmp-1346 (apply (lambda (syntmp-x-1347) (call-with-values (lambda () (syntmp-cvt-1326 syntmp-x-1347 syntmp-n-1328 syntmp-ids-1329)) (lambda (syntmp-p-1349 syntmp-ids-1350) (values (vector (quote vector) syntmp-p-1349) syntmp-ids-1350)))) syntmp-tmp-1346) ((lambda (syntmp-x-1351) (values (vector (quote atom) (syntmp-strip-162 syntmp-p-1327 (quote (())))) syntmp-ids-1329)) syntmp-tmp-1330))) (syntax-dispatch syntmp-tmp-1330 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1330 (quote ()))))) (syntax-dispatch syntmp-tmp-1330 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1330 (quote (any any))))) syntmp-p-1327)))))) (lambda (syntmp-e-1352 syntmp-r-1353 syntmp-w-1354 syntmp-s-1355) (let ((syntmp-e-1356 (syntmp-source-wrap-144 syntmp-e-1352 syntmp-w-1354 syntmp-s-1355))) ((lambda (syntmp-tmp-1357) ((lambda (syntmp-tmp-1358) (if syntmp-tmp-1358 (apply (lambda (syntmp-_-1359 syntmp-val-1360 syntmp-key-1361 syntmp-m-1362) (if (andmap (lambda (syntmp-x-1363) (and (syntmp-id?-115 syntmp-x-1363) (not (syntmp-ellipsis?-160 syntmp-x-1363)))) syntmp-key-1361) (let ((syntmp-x-1365 (syntmp-gen-var-163 (quote tmp)))) (list (list (quote lambda) (list syntmp-x-1365) (syntmp-gen-syntax-case-1282 syntmp-x-1365 syntmp-key-1361 syntmp-m-1362 syntmp-r-1353)) (syntmp-chi-151 syntmp-val-1360 syntmp-r-1353 (quote (()))))) (syntax-error syntmp-e-1356 "invalid literals list in"))) syntmp-tmp-1358) (syntax-error syntmp-tmp-1357))) (syntax-dispatch syntmp-tmp-1357 (quote (any any each-any . each-any))))) syntmp-e-1356))))) (set! sc-expand (let ((syntmp-m-1368 (quote e)) (syntmp-esew-1369 (quote (eval)))) (lambda (syntmp-x-1370) (if (and (pair? syntmp-x-1370) (equal? (car syntmp-x-1370) syntmp-noexpand-84)) (cadr syntmp-x-1370) (syntmp-chi-top-150 syntmp-x-1370 (quote ()) (quote ((top))) syntmp-m-1368 syntmp-esew-1369))))) (set! sc-expand3 (let ((syntmp-m-1371 (quote e)) (syntmp-esew-1372 (quote (eval)))) (lambda (syntmp-x-1374 . syntmp-rest-1373) (if (and (pair? syntmp-x-1374) (equal? (car syntmp-x-1374) syntmp-noexpand-84)) (cadr syntmp-x-1374) (syntmp-chi-top-150 syntmp-x-1374 (quote ()) (quote ((top))) (if (null? syntmp-rest-1373) syntmp-m-1371 (car syntmp-rest-1373)) (if (or (null? syntmp-rest-1373) (null? (cdr syntmp-rest-1373))) syntmp-esew-1372 (cadr syntmp-rest-1373))))))) (set! identifier? (lambda (syntmp-x-1375) (syntmp-nonsymbol-id?-114 syntmp-x-1375))) (set! datum->syntax-object (lambda (syntmp-id-1376 syntmp-datum-1377) (syntmp-make-syntax-object-100 syntmp-datum-1377 (syntmp-syntax-object-wrap-103 syntmp-id-1376)))) (set! syntax-object->datum (lambda (syntmp-x-1378) (syntmp-strip-162 syntmp-x-1378 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1379) (begin (let ((syntmp-x-1380 syntmp-ls-1379)) (if (not (list? syntmp-x-1380)) (syntmp-error-hook-92 (quote generate-temporaries) "invalid argument" syntmp-x-1380))) (map (lambda (syntmp-x-1381) (syntmp-wrap-143 (gensym) (quote ((top))))) syntmp-ls-1379)))) (set! free-identifier=? (lambda (syntmp-x-1382 syntmp-y-1383) (begin (let ((syntmp-x-1384 syntmp-x-1382)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1384)) (syntmp-error-hook-92 (quote free-identifier=?) "invalid argument" syntmp-x-1384))) (let ((syntmp-x-1385 syntmp-y-1383)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1385)) (syntmp-error-hook-92 (quote free-identifier=?) "invalid argument" syntmp-x-1385))) (syntmp-free-id=?-138 syntmp-x-1382 syntmp-y-1383)))) (set! bound-identifier=? (lambda (syntmp-x-1386 syntmp-y-1387) (begin (let ((syntmp-x-1388 syntmp-x-1386)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1388)) (syntmp-error-hook-92 (quote bound-identifier=?) "invalid argument" syntmp-x-1388))) (let ((syntmp-x-1389 syntmp-y-1387)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1389)) (syntmp-error-hook-92 (quote bound-identifier=?) "invalid argument" syntmp-x-1389))) (syntmp-bound-id=?-139 syntmp-x-1386 syntmp-y-1387)))) (set! syntax-error (lambda (syntmp-object-1391 . syntmp-messages-1390) (begin (for-each (lambda (syntmp-x-1392) (let ((syntmp-x-1393 syntmp-x-1392)) (if (not (string? syntmp-x-1393)) (syntmp-error-hook-92 (quote syntax-error) "invalid argument" syntmp-x-1393)))) syntmp-messages-1390) (let ((syntmp-message-1394 (if (null? syntmp-messages-1390) "invalid syntax" (apply string-append syntmp-messages-1390)))) (syntmp-error-hook-92 #f syntmp-message-1394 (syntmp-strip-162 syntmp-object-1391 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1395 syntmp-v-1396) (begin (let ((syntmp-x-1397 syntmp-sym-1395)) (if (not (symbol? syntmp-x-1397)) (syntmp-error-hook-92 (quote define-syntax) "invalid argument" syntmp-x-1397))) (let ((syntmp-x-1398 syntmp-v-1396)) (if (not (procedure? syntmp-x-1398)) (syntmp-error-hook-92 (quote define-syntax) "invalid argument" syntmp-x-1398))) (syntmp-global-extend-113 (quote macro) syntmp-sym-1395 syntmp-v-1396)))) (letrec ((syntmp-match-1403 (lambda (syntmp-e-1404 syntmp-p-1405 syntmp-w-1406 syntmp-r-1407) (cond ((not syntmp-r-1407) #f) ((eq? syntmp-p-1405 (quote any)) (cons (syntmp-wrap-143 syntmp-e-1404 syntmp-w-1406) syntmp-r-1407)) ((syntmp-syntax-object?-101 syntmp-e-1404) (syntmp-match*-1402 (let ((syntmp-e-1408 (syntmp-syntax-object-expression-102 syntmp-e-1404))) (if (syntmp-annotation?-89 syntmp-e-1408) (annotation-expression syntmp-e-1408) syntmp-e-1408)) syntmp-p-1405 (syntmp-join-wraps-134 syntmp-w-1406 (syntmp-syntax-object-wrap-103 syntmp-e-1404)) syntmp-r-1407)) (else (syntmp-match*-1402 (let ((syntmp-e-1409 syntmp-e-1404)) (if (syntmp-annotation?-89 syntmp-e-1409) (annotation-expression syntmp-e-1409) syntmp-e-1409)) syntmp-p-1405 syntmp-w-1406 syntmp-r-1407))))) (syntmp-match*-1402 (lambda (syntmp-e-1410 syntmp-p-1411 syntmp-w-1412 syntmp-r-1413) (cond ((null? syntmp-p-1411) (and (null? syntmp-e-1410) syntmp-r-1413)) ((pair? syntmp-p-1411) (and (pair? syntmp-e-1410) (syntmp-match-1403 (car syntmp-e-1410) (car syntmp-p-1411) syntmp-w-1412 (syntmp-match-1403 (cdr syntmp-e-1410) (cdr syntmp-p-1411) syntmp-w-1412 syntmp-r-1413)))) ((eq? syntmp-p-1411 (quote each-any)) (let ((syntmp-l-1414 (syntmp-match-each-any-1400 syntmp-e-1410 syntmp-w-1412))) (and syntmp-l-1414 (cons syntmp-l-1414 syntmp-r-1413)))) (else (let ((syntmp-t-1415 (vector-ref syntmp-p-1411 0))) (if (memv syntmp-t-1415 (quote (each))) (if (null? syntmp-e-1410) (syntmp-match-empty-1401 (vector-ref syntmp-p-1411 1) syntmp-r-1413) (let ((syntmp-l-1416 (syntmp-match-each-1399 syntmp-e-1410 (vector-ref syntmp-p-1411 1) syntmp-w-1412))) (and syntmp-l-1416 (let syntmp-collect-1417 ((syntmp-l-1418 syntmp-l-1416)) (if (null? (car syntmp-l-1418)) syntmp-r-1413 (cons (map car syntmp-l-1418) (syntmp-collect-1417 (map cdr syntmp-l-1418)))))))) (if (memv syntmp-t-1415 (quote (free-id))) (and (syntmp-id?-115 syntmp-e-1410) (syntmp-free-id=?-138 (syntmp-wrap-143 syntmp-e-1410 syntmp-w-1412) (vector-ref syntmp-p-1411 1)) syntmp-r-1413) (if (memv syntmp-t-1415 (quote (atom))) (and (equal? (vector-ref syntmp-p-1411 1) (syntmp-strip-162 syntmp-e-1410 syntmp-w-1412)) syntmp-r-1413) (if (memv syntmp-t-1415 (quote (vector))) (and (vector? syntmp-e-1410) (syntmp-match-1403 (vector->list syntmp-e-1410) (vector-ref syntmp-p-1411 1) syntmp-w-1412 syntmp-r-1413))))))))))) (syntmp-match-empty-1401 (lambda (syntmp-p-1419 syntmp-r-1420) (cond ((null? syntmp-p-1419) syntmp-r-1420) ((eq? syntmp-p-1419 (quote any)) (cons (quote ()) syntmp-r-1420)) ((pair? syntmp-p-1419) (syntmp-match-empty-1401 (car syntmp-p-1419) (syntmp-match-empty-1401 (cdr syntmp-p-1419) syntmp-r-1420))) ((eq? syntmp-p-1419 (quote each-any)) (cons (quote ()) syntmp-r-1420)) (else (let ((syntmp-t-1421 (vector-ref syntmp-p-1419 0))) (if (memv syntmp-t-1421 (quote (each))) (syntmp-match-empty-1401 (vector-ref syntmp-p-1419 1) syntmp-r-1420) (if (memv syntmp-t-1421 (quote (free-id atom))) syntmp-r-1420 (if (memv syntmp-t-1421 (quote (vector))) (syntmp-match-empty-1401 (vector-ref syntmp-p-1419 1) syntmp-r-1420))))))))) (syntmp-match-each-any-1400 (lambda (syntmp-e-1422 syntmp-w-1423) (cond ((syntmp-annotation?-89 syntmp-e-1422) (syntmp-match-each-any-1400 (annotation-expression syntmp-e-1422) syntmp-w-1423)) ((pair? syntmp-e-1422) (let ((syntmp-l-1424 (syntmp-match-each-any-1400 (cdr syntmp-e-1422) syntmp-w-1423))) (and syntmp-l-1424 (cons (syntmp-wrap-143 (car syntmp-e-1422) syntmp-w-1423) syntmp-l-1424)))) ((null? syntmp-e-1422) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1422) (syntmp-match-each-any-1400 (syntmp-syntax-object-expression-102 syntmp-e-1422) (syntmp-join-wraps-134 syntmp-w-1423 (syntmp-syntax-object-wrap-103 syntmp-e-1422)))) (else #f)))) (syntmp-match-each-1399 (lambda (syntmp-e-1425 syntmp-p-1426 syntmp-w-1427) (cond ((syntmp-annotation?-89 syntmp-e-1425) (syntmp-match-each-1399 (annotation-expression syntmp-e-1425) syntmp-p-1426 syntmp-w-1427)) ((pair? syntmp-e-1425) (let ((syntmp-first-1428 (syntmp-match-1403 (car syntmp-e-1425) syntmp-p-1426 syntmp-w-1427 (quote ())))) (and syntmp-first-1428 (let ((syntmp-rest-1429 (syntmp-match-each-1399 (cdr syntmp-e-1425) syntmp-p-1426 syntmp-w-1427))) (and syntmp-rest-1429 (cons syntmp-first-1428 syntmp-rest-1429)))))) ((null? syntmp-e-1425) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1425) (syntmp-match-each-1399 (syntmp-syntax-object-expression-102 syntmp-e-1425) syntmp-p-1426 (syntmp-join-wraps-134 syntmp-w-1427 (syntmp-syntax-object-wrap-103 syntmp-e-1425)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1430 syntmp-p-1431) (cond ((eq? syntmp-p-1431 (quote any)) (list syntmp-e-1430)) ((syntmp-syntax-object?-101 syntmp-e-1430) (syntmp-match*-1402 (let ((syntmp-e-1432 (syntmp-syntax-object-expression-102 syntmp-e-1430))) (if (syntmp-annotation?-89 syntmp-e-1432) (annotation-expression syntmp-e-1432) syntmp-e-1432)) syntmp-p-1431 (syntmp-syntax-object-wrap-103 syntmp-e-1430) (quote ()))) (else (syntmp-match*-1402 (let ((syntmp-e-1433 syntmp-e-1430)) (if (syntmp-annotation?-89 syntmp-e-1433) (annotation-expression syntmp-e-1433) syntmp-e-1433)) syntmp-p-1431 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-151)))))
-(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1434) ((lambda (syntmp-tmp-1435) ((lambda (syntmp-tmp-1436) (if syntmp-tmp-1436 (apply (lambda (syntmp-_-1437 syntmp-e1-1438 syntmp-e2-1439) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1438 syntmp-e2-1439))) syntmp-tmp-1436) ((lambda (syntmp-tmp-1441) (if syntmp-tmp-1441 (apply (lambda (syntmp-_-1442 syntmp-out-1443 syntmp-in-1444 syntmp-e1-1445 syntmp-e2-1446) (list (quote #(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"))))) syntmp-in-1444 (quote ()) (list syntmp-out-1443 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1445 syntmp-e2-1446))))) syntmp-tmp-1441) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda (syntmp-_-1449 syntmp-out-1450 syntmp-in-1451 syntmp-e1-1452 syntmp-e2-1453) (list (quote #(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"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1451) (quote ()) (list syntmp-out-1450 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1452 syntmp-e2-1453))))) syntmp-tmp-1448) (syntax-error syntmp-tmp-1435))) (syntax-dispatch syntmp-tmp-1435 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1435 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1435 (quote (any () any . each-any))))) syntmp-x-1434)))
-(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1475) ((lambda (syntmp-tmp-1476) ((lambda (syntmp-tmp-1477) (if syntmp-tmp-1477 (apply (lambda (syntmp-_-1478 syntmp-k-1479 syntmp-keyword-1480 syntmp-pattern-1481 syntmp-template-1482) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(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"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1479 (map (lambda (syntmp-tmp-1485 syntmp-tmp-1484) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1484) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1485))) syntmp-template-1482 syntmp-pattern-1481)))))) syntmp-tmp-1477) (syntax-error syntmp-tmp-1476))) (syntax-dispatch syntmp-tmp-1476 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1475)))
-(install-global-transformer (quote let*) (lambda (syntmp-x-1496) ((lambda (syntmp-tmp-1497) ((lambda (syntmp-tmp-1498) (if (if syntmp-tmp-1498 (apply (lambda (syntmp-let*-1499 syntmp-x-1500 syntmp-v-1501 syntmp-e1-1502 syntmp-e2-1503) (andmap identifier? syntmp-x-1500)) syntmp-tmp-1498) #f) (apply (lambda (syntmp-let*-1505 syntmp-x-1506 syntmp-v-1507 syntmp-e1-1508 syntmp-e2-1509) (let syntmp-f-1510 ((syntmp-bindings-1511 (map list syntmp-x-1506 syntmp-v-1507))) (if (null? syntmp-bindings-1511) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1508 syntmp-e2-1509))) ((lambda (syntmp-tmp-1515) ((lambda (syntmp-tmp-1516) (if syntmp-tmp-1516 (apply (lambda (syntmp-body-1517 syntmp-binding-1518) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1518) syntmp-body-1517)) syntmp-tmp-1516) (syntax-error syntmp-tmp-1515))) (syntax-dispatch syntmp-tmp-1515 (quote (any any))))) (list (syntmp-f-1510 (cdr syntmp-bindings-1511)) (car syntmp-bindings-1511)))))) syntmp-tmp-1498) (syntax-error syntmp-tmp-1497))) (syntax-dispatch syntmp-tmp-1497 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1496)))
-(install-global-transformer (quote do) (lambda (syntmp-orig-x-1538) ((lambda (syntmp-tmp-1539) ((lambda (syntmp-tmp-1540) (if syntmp-tmp-1540 (apply (lambda (syntmp-_-1541 syntmp-var-1542 syntmp-init-1543 syntmp-step-1544 syntmp-e0-1545 syntmp-e1-1546 syntmp-c-1547) ((lambda (syntmp-tmp-1548) ((lambda (syntmp-tmp-1549) (if syntmp-tmp-1549 (apply (lambda (syntmp-step-1550) ((lambda (syntmp-tmp-1551) ((lambda (syntmp-tmp-1552) (if syntmp-tmp-1552 (apply (lambda () (list (quote #(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"))))) (quote #(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"))))) (map list syntmp-var-1542 syntmp-init-1543) (list (quote #(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"))))) (list (quote #(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"))))) syntmp-e0-1545) (cons (quote #(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"))))) (append syntmp-c-1547 (list (cons (quote #(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"))))) syntmp-step-1550))))))) syntmp-tmp-1552) ((lambda (syntmp-tmp-1557) (if syntmp-tmp-1557 (apply (lambda (syntmp-e1-1558 syntmp-e2-1559) (list (quote #(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"))))) (quote #(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"))))) (map list syntmp-var-1542 syntmp-init-1543) (list (quote #(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"))))) syntmp-e0-1545 (cons (quote #(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"))))) (cons syntmp-e1-1558 syntmp-e2-1559)) (cons (quote #(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"))))) (append syntmp-c-1547 (list (cons (quote #(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"))))) syntmp-step-1550))))))) syntmp-tmp-1557) (syntax-error syntmp-tmp-1551))) (syntax-dispatch syntmp-tmp-1551 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1551 (quote ())))) syntmp-e1-1546)) syntmp-tmp-1549) (syntax-error syntmp-tmp-1548))) (syntax-dispatch syntmp-tmp-1548 (quote each-any)))) (map (lambda (syntmp-v-1566 syntmp-s-1567) ((lambda (syntmp-tmp-1568) ((lambda (syntmp-tmp-1569) (if syntmp-tmp-1569 (apply (lambda () syntmp-v-1566) syntmp-tmp-1569) ((lambda (syntmp-tmp-1570) (if syntmp-tmp-1570 (apply (lambda (syntmp-e-1571) syntmp-e-1571) syntmp-tmp-1570) ((lambda (syntmp-_-1572) (syntax-error syntmp-orig-x-1538)) syntmp-tmp-1568))) (syntax-dispatch syntmp-tmp-1568 (quote (any)))))) (syntax-dispatch syntmp-tmp-1568 (quote ())))) syntmp-s-1567)) syntmp-var-1542 syntmp-step-1544))) syntmp-tmp-1540) (syntax-error syntmp-tmp-1539))) (syntax-dispatch syntmp-tmp-1539 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1538)))
-(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1600 (lambda (syntmp-x-1604 syntmp-y-1605) ((lambda (syntmp-tmp-1606) ((lambda (syntmp-tmp-1607) (if syntmp-tmp-1607 (apply (lambda (syntmp-x-1608 syntmp-y-1609) ((lambda (syntmp-tmp-1610) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-dy-1612) ((lambda (syntmp-tmp-1613) ((lambda (syntmp-tmp-1614) (if syntmp-tmp-1614 (apply (lambda (syntmp-dx-1615) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1615 syntmp-dy-1612))) syntmp-tmp-1614) ((lambda (syntmp-_-1616) (if (null? syntmp-dy-1612) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1608) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1608 syntmp-y-1609))) syntmp-tmp-1613))) (syntax-dispatch syntmp-tmp-1613 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1608)) syntmp-tmp-1611) ((lambda (syntmp-tmp-1617) (if syntmp-tmp-1617 (apply (lambda (syntmp-stuff-1618) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1608 syntmp-stuff-1618))) syntmp-tmp-1617) ((lambda (syntmp-else-1619) (list (quote #(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 #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1608 syntmp-y-1609)) syntmp-tmp-1610))) (syntax-dispatch syntmp-tmp-1610 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1610 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1609)) syntmp-tmp-1607) (syntax-error syntmp-tmp-1606))) (syntax-dispatch syntmp-tmp-1606 (quote (any any))))) (list syntmp-x-1604 syntmp-y-1605)))) (syntmp-quasiappend-1601 (lambda (syntmp-x-1620 syntmp-y-1621) ((lambda (syntmp-tmp-1622) ((lambda (syntmp-tmp-1623) (if syntmp-tmp-1623 (apply (lambda (syntmp-x-1624 syntmp-y-1625) ((lambda (syntmp-tmp-1626) ((lambda (syntmp-tmp-1627) (if syntmp-tmp-1627 (apply (lambda () syntmp-x-1624) syntmp-tmp-1627) ((lambda (syntmp-_-1628) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1624 syntmp-y-1625)) syntmp-tmp-1626))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1625)) syntmp-tmp-1623) (syntax-error syntmp-tmp-1622))) (syntax-dispatch syntmp-tmp-1622 (quote (any any))))) (list syntmp-x-1620 syntmp-y-1621)))) (syntmp-quasivector-1602 (lambda (syntmp-x-1629) ((lambda (syntmp-tmp-1630) ((lambda (syntmp-x-1631) ((lambda (syntmp-tmp-1632) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-x-1634) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1634))) syntmp-tmp-1633) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda (syntmp-x-1637) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1637)) syntmp-tmp-1636) ((lambda (syntmp-_-1639) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1631)) syntmp-tmp-1632))) (syntax-dispatch syntmp-tmp-1632 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1632 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1631)) syntmp-tmp-1630)) syntmp-x-1629))) (syntmp-quasi-1603 (lambda (syntmp-p-1640 syntmp-lev-1641) ((lambda (syntmp-tmp-1642) ((lambda (syntmp-tmp-1643) (if syntmp-tmp-1643 (apply (lambda (syntmp-p-1644) (if (= syntmp-lev-1641 0) syntmp-p-1644 (syntmp-quasicons-1600 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1603 (list syntmp-p-1644) (- syntmp-lev-1641 1))))) syntmp-tmp-1643) ((lambda (syntmp-tmp-1645) (if syntmp-tmp-1645 (apply (lambda (syntmp-p-1646 syntmp-q-1647) (if (= syntmp-lev-1641 0) (syntmp-quasiappend-1601 syntmp-p-1646 (syntmp-quasi-1603 syntmp-q-1647 syntmp-lev-1641)) (syntmp-quasicons-1600 (syntmp-quasicons-1600 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1603 (list syntmp-p-1646) (- syntmp-lev-1641 1))) (syntmp-quasi-1603 syntmp-q-1647 syntmp-lev-1641)))) syntmp-tmp-1645) ((lambda (syntmp-tmp-1648) (if syntmp-tmp-1648 (apply (lambda (syntmp-p-1649) (syntmp-quasicons-1600 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1603 (list syntmp-p-1649) (+ syntmp-lev-1641 1)))) syntmp-tmp-1648) ((lambda (syntmp-tmp-1650) (if syntmp-tmp-1650 (apply (lambda (syntmp-p-1651 syntmp-q-1652) (syntmp-quasicons-1600 (syntmp-quasi-1603 syntmp-p-1651 syntmp-lev-1641) (syntmp-quasi-1603 syntmp-q-1652 syntmp-lev-1641))) syntmp-tmp-1650) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda (syntmp-x-1654) (syntmp-quasivector-1602 (syntmp-quasi-1603 syntmp-x-1654 syntmp-lev-1641))) syntmp-tmp-1653) ((lambda (syntmp-p-1656) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1656)) syntmp-tmp-1642))) (syntax-dispatch syntmp-tmp-1642 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1642 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1642 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1642 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1642 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1640)))) (lambda (syntmp-x-1657) ((lambda (syntmp-tmp-1658) ((lambda (syntmp-tmp-1659) (if syntmp-tmp-1659 (apply (lambda (syntmp-_-1660 syntmp-e-1661) (syntmp-quasi-1603 syntmp-e-1661 0)) syntmp-tmp-1659) (syntax-error syntmp-tmp-1658))) (syntax-dispatch syntmp-tmp-1658 (quote (any any))))) syntmp-x-1657))))
-(install-global-transformer (quote include) (lambda (syntmp-x-1721) (letrec ((syntmp-read-file-1722 (lambda (syntmp-fn-1723 syntmp-k-1724) (let ((syntmp-p-1725 (open-input-file syntmp-fn-1723))) (let syntmp-f-1726 ((syntmp-x-1727 (read syntmp-p-1725))) (if (eof-object? syntmp-x-1727) (begin (close-input-port syntmp-p-1725) (quote ())) (cons (datum->syntax-object syntmp-k-1724 syntmp-x-1727) (syntmp-f-1726 (read syntmp-p-1725))))))))) ((lambda (syntmp-tmp-1728) ((lambda (syntmp-tmp-1729) (if syntmp-tmp-1729 (apply (lambda (syntmp-k-1730 syntmp-filename-1731) (let ((syntmp-fn-1732 (syntax-object->datum syntmp-filename-1731))) ((lambda (syntmp-tmp-1733) ((lambda (syntmp-tmp-1734) (if syntmp-tmp-1734 (apply (lambda (syntmp-exp-1735) (cons (quote #(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"))))) syntmp-exp-1735)) syntmp-tmp-1734) (syntax-error syntmp-tmp-1733))) (syntax-dispatch syntmp-tmp-1733 (quote each-any)))) (syntmp-read-file-1722 syntmp-fn-1732 syntmp-k-1730)))) syntmp-tmp-1729) (syntax-error syntmp-tmp-1728))) (syntax-dispatch syntmp-tmp-1728 (quote (any any))))) syntmp-x-1721))))
-(install-global-transformer (quote unquote) (lambda (syntmp-x-1752) ((lambda (syntmp-tmp-1753) ((lambda (syntmp-tmp-1754) (if syntmp-tmp-1754 (apply (lambda (syntmp-_-1755 syntmp-e-1756) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1756))) syntmp-tmp-1754) (syntax-error syntmp-tmp-1753))) (syntax-dispatch syntmp-tmp-1753 (quote (any any))))) syntmp-x-1752)))
-(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1762) ((lambda (syntmp-tmp-1763) ((lambda (syntmp-tmp-1764) (if syntmp-tmp-1764 (apply (lambda (syntmp-_-1765 syntmp-e-1766) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1766))) syntmp-tmp-1764) (syntax-error syntmp-tmp-1763))) (syntax-dispatch syntmp-tmp-1763 (quote (any any))))) syntmp-x-1762)))
-(install-global-transformer (quote case) (lambda (syntmp-x-1772) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-tmp-1774) (if syntmp-tmp-1774 (apply (lambda (syntmp-_-1775 syntmp-e-1776 syntmp-m1-1777 syntmp-m2-1778) ((lambda (syntmp-tmp-1779) ((lambda (syntmp-body-1780) (list (quote #(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"))))) (list (list (quote #(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"))))) syntmp-e-1776)) syntmp-body-1780)) syntmp-tmp-1779)) (let syntmp-f-1781 ((syntmp-clause-1782 syntmp-m1-1777) (syntmp-clauses-1783 syntmp-m2-1778)) (if (null? syntmp-clauses-1783) ((lambda (syntmp-tmp-1785) ((lambda (syntmp-tmp-1786) (if syntmp-tmp-1786 (apply (lambda (syntmp-e1-1787 syntmp-e2-1788) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1787 syntmp-e2-1788))) syntmp-tmp-1786) ((lambda (syntmp-tmp-1790) (if syntmp-tmp-1790 (apply (lambda (syntmp-k-1791 syntmp-e1-1792 syntmp-e2-1793) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1791)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1792 syntmp-e2-1793)))) syntmp-tmp-1790) ((lambda (syntmp-_-1796) (syntax-error syntmp-x-1772)) syntmp-tmp-1785))) (syntax-dispatch syntmp-tmp-1785 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1785 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1782) ((lambda (syntmp-tmp-1797) ((lambda (syntmp-rest-1798) ((lambda (syntmp-tmp-1799) ((lambda (syntmp-tmp-1800) (if syntmp-tmp-1800 (apply (lambda (syntmp-k-1801 syntmp-e1-1802 syntmp-e2-1803) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1801)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1802 syntmp-e2-1803)) syntmp-rest-1798)) syntmp-tmp-1800) ((lambda (syntmp-_-1806) (syntax-error syntmp-x-1772)) syntmp-tmp-1799))) (syntax-dispatch syntmp-tmp-1799 (quote (each-any any . each-any))))) syntmp-clause-1782)) syntmp-tmp-1797)) (syntmp-f-1781 (car syntmp-clauses-1783) (cdr syntmp-clauses-1783))))))) syntmp-tmp-1774) (syntax-error syntmp-tmp-1773))) (syntax-dispatch syntmp-tmp-1773 (quote (any any any . each-any))))) syntmp-x-1772)))
-(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1836) ((lambda (syntmp-tmp-1837) ((lambda (syntmp-tmp-1838) (if syntmp-tmp-1838 (apply (lambda (syntmp-_-1839 syntmp-e-1840) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1840)) (list (cons syntmp-_-1839 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1840 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1838) (syntax-error syntmp-tmp-1837))) (syntax-dispatch syntmp-tmp-1837 (quote (any any))))) syntmp-x-1836)))
libpath.h
scmconfig.h
version.h
+vm-i-*.i
if [ "$(cross_compiling)" = "yes" ]; then \
$(CC_FOR_BUILD) $(DEFS) $(AM_CPPFLAGS) -c -o $@ $<; \
else \
- $(COMPILE) -c -o $@ $<; \
+ $(filter-out -Werror,$(COMPILE)) -c -o $@ $<; \
fi
## Override default rule; this should run on BUILD host.
throw.c values.c variable.c vectors.c version.c vports.c weaks.c \
ramap.c unif.c
+# vm-related sources
+libguile_la_SOURCES += frames.c instructions.c objcodes.c programs.c vm.c
+
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
$(libguile_la_CFLAGS)
strports.x struct.x symbols.x threads.x throw.x values.x \
variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x
+# vm-related snarfs
+DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
+
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
+DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
+
+.c.i:
+ grep '^VM_DEFINE' $< > $@
+
BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
version.h scmconfig.h \
- $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
+ $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
EXTRA_libguile_la_SOURCES = _scm.h \
inet_aton.c memmove.c putenv.c strerror.c \
win32-uname.h win32-dirent.h win32-socket.h \
private-gc.h private-options.h
+# vm instructions
+noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
+
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
pthread-threads.h null-threads.h throw.h unif.h values.h \
variable.h vectors.h vports.h weaks.h
+modinclude_HEADERS += vm-bootstrap.h frames.h instructions.h objcodes.h \
+ programs.h vm.h vm-engine.h vm-expand.h
+
nodist_modinclude_HEADERS = version.h scmconfig.h
bin_SCRIPTS = guile-snarf
display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
{
SCM source = SCM_FRAME_SOURCE (frame);
- *file = SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) : SCM_BOOL_F;
- *line = (SCM_MEMOIZEDP (source)) ? scm_source_property (source, scm_sym_line) : SCM_BOOL_F;
+ *file = *line = SCM_BOOL_F;
+ if (SCM_MEMOIZEDP (source))
+ {
+ *file = scm_source_property (source, scm_sym_filename);
+ *line = scm_source_property (source, scm_sym_line);
+ }
+ else if (scm_is_pair (source)
+ && scm_is_pair (scm_cdr (source))
+ && scm_is_pair (scm_cddr (source))
+ && !scm_is_pair (scm_cdddr (source)))
+ {
+ /* (addr . (filename . (line . column))), from vm compilation */
+ *file = scm_cadr (source);
+ *line = scm_caddr (source);
+ }
}
static void
#include "libguile/dynwind.h"
#include "libguile/values.h"
#include "libguile/eval.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/continuations.h"
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)
#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)
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
#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
#include "libguile/root.h"
#include "libguile/fluids.h"
#include "libguile/objects.h"
+#include "libguile/programs.h"
#include "libguile/validate.h"
#include "libguile/debug.h"
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 ();
#endif
if (scm_is_false (name) && SCM_CLOSUREP (proc))
name = scm_reverse_lookup (SCM_ENV (proc), proc);
+ if (scm_is_false (name) && SCM_PROGRAM_P (proc))
+ name = scm_program_name (proc);
return name;
}
}
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;
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.
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);
if (SCM_VARIABLEP (SCM_CAR (wind_key)))
scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
}
- else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
+ else if (scm_is_true (scm_thunk_p (wind_key)))
scm_call_0 (wind_key);
}
}
if (SCM_VARIABLEP (SCM_CAR (wind_key)))
scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
}
- else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
+ else if (scm_is_true (scm_thunk_p (wind_key)))
scm_call_0 (SCM_CDR (wind_elt));
}
}
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/procprop.h"
+#include "libguile/programs.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/srcprop.h"
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/vectors.h"
+#include "libguile/vm.h"
#include "libguile/eval.h"
#include "libguile/private-options.h"
{ SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
{ SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
- { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
+ { SCM_OPTION_INTEGER, "stack", 40000, "Stack size limit (measured in words; 0 = no check)." },
{ SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
"Show file names and line numbers "
"in backtraces when not `#f'. A value of `base' "
SCM
scm_call_0 (SCM proc)
{
- return scm_apply (proc, SCM_EOL, SCM_EOL);
+ if (SCM_PROGRAM_P (proc))
+ return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
+ else
+ return scm_apply (proc, SCM_EOL, SCM_EOL);
}
SCM
scm_call_1 (SCM proc, SCM arg1)
{
- return scm_apply (proc, arg1, scm_listofnull);
+ if (SCM_PROGRAM_P (proc))
+ return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
+ else
+ return scm_apply (proc, arg1, scm_listofnull);
}
SCM
scm_call_2 (SCM proc, SCM arg1, SCM arg2)
{
- return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
+ if (SCM_PROGRAM_P (proc))
+ {
+ SCM args[] = { arg1, arg2 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 2);
+ }
+ else
+ return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
}
SCM
scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
{
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
+ if (SCM_PROGRAM_P (proc))
+ {
+ SCM args[] = { arg1, arg2, arg3 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 3);
+ }
+ else
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
}
SCM
scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
{
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
- scm_cons (arg4, scm_listofnull)));
+ if (SCM_PROGRAM_P (proc))
+ {
+ SCM args[] = { arg1, arg2, arg3, arg4 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 4);
+ }
+ else
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
+ scm_cons (arg4, scm_listofnull)));
}
/* Simple procedure applies
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)
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);
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.
args = SCM_CDR (args);
z = SCM_CDR (z);
}
- /* Fewer arguments than specifiers => CAR != ENV */
- if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
- goto apply_cmethod;
+ /* Fewer arguments than specifiers => CAR != CLASS */
+ if (!scm_is_pair (z))
+ goto apply_vm_cmethod;
+ else if (!SCM_CLASSP (SCM_CAR (z))
+ && !scm_is_symbol (SCM_CAR (z)))
+ goto apply_memoized_cmethod;
next_method:
hash_value = (hash_value + 1) & mask;
} while (hash_value != cache_end_pos);
/* No appropriate method was found in the cache. */
z = scm_memoize_method (x, arg1);
- apply_cmethod: /* inputs: z, arg1 */
- {
- SCM formals = SCM_CMETHOD_FORMALS (z);
- env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
- x = SCM_CMETHOD_BODY (z);
- goto nontoplevel_begin;
- }
+ if (scm_is_pair (z))
+ goto apply_memoized_cmethod;
+
+ apply_vm_cmethod:
+ proc = z;
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
+
+ apply_memoized_cmethod: /* inputs: z, arg1 */
+ {
+ SCM formals = SCM_CMETHOD_FORMALS (z);
+ env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
+ x = SCM_CMETHOD_BODY (z);
+ goto nontoplevel_begin;
+ }
}
}
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "frames.h"
+
+\f
+scm_t_bits scm_tc16_vm_frame;
+
+#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
+
+SCM
+scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+ scm_byte_t *ip, scm_t_ptrdiff offset)
+{
+ struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
+ "vmframe");
+ p->stack_holder = stack_holder;
+ p->fp = fp;
+ p->sp = sp;
+ p->ip = ip;
+ p->offset = offset;
+ SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p);
+}
+
+static int
+vm_frame_print (SCM frame, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm-frame ", port);
+ scm_uintprint (SCM_UNPACK (frame), 16, port);
+ scm_putc (' ', port);
+ scm_write (scm_vm_frame_program (frame), port);
+ /* don't write args, they can get us into trouble. */
+ scm_puts (">", port);
+
+ return 1;
+}
+
+static SCM
+vm_frame_mark (SCM obj)
+{
+ return SCM_VM_FRAME_STACK_HOLDER (obj);
+}
+
+static scm_sizet
+vm_frame_free (SCM obj)
+{
+ struct scm_vm_frame *p = SCM_VM_FRAME_DATA (obj);
+ scm_gc_free (p, sizeof(struct scm_vm_frame), "vmframe");
+ return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_vm_frame_p
+{
+ return SCM_BOOL (SCM_VM_FRAME_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_program
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_arguments
+{
+ SCM *fp;
+ int i;
+ struct scm_objcode *bp;
+ SCM ret;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ fp = SCM_VM_FRAME_FP (frame);
+ bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+ if (!bp->nargs)
+ return SCM_EOL;
+ else if (bp->nrest)
+ ret = fp[bp->nargs - 1];
+ else
+ ret = scm_cons (fp[bp->nargs - 1], SCM_EOL);
+
+ for (i = bp->nargs - 2; i >= 0; i--)
+ ret = scm_cons (fp[i], ret);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_source
+{
+ SCM *fp;
+ struct scm_objcode *bp;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ fp = SCM_VM_FRAME_FP (frame);
+ bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+ return scm_c_program_source (SCM_FRAME_PROGRAM (fp),
+ SCM_VM_FRAME_IP (frame) - bp->base);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
+ (SCM frame, SCM index),
+ "")
+#define FUNC_NAME s_scm_vm_frame_local_ref
+{
+ SCM *fp;
+ unsigned int i;
+ struct scm_objcode *bp;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ fp = SCM_VM_FRAME_FP (frame);
+ bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+ SCM_VALIDATE_UINT_COPY (2, index, i);
+ SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
+
+ return SCM_FRAME_VARIABLE (fp, i);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
+ (SCM frame, SCM index, SCM val),
+ "")
+#define FUNC_NAME s_scm_vm_frame_local_set_x
+{
+ SCM *fp;
+ unsigned int i;
+ struct scm_objcode *bp;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ fp = SCM_VM_FRAME_FP (frame);
+ bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+ SCM_VALIDATE_UINT_COPY (2, index, i);
+ SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
+
+ SCM_FRAME_VARIABLE (fp, i) = val;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_return_address
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_FRAME_RETURN_ADDRESS
+ (SCM_VM_FRAME_FP (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_mv_return_address
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_FRAME_MV_RETURN_ADDRESS
+ (SCM_VM_FRAME_FP (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_dynamic_link
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ /* fixme: munge fp if holder is a continuation */
+ return scm_from_ulong
+ ((unsigned long)
+ RELOC (frame,
+ SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_external_link
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_stack
+{
+ SCM *top, *bottom, ret = SCM_EOL;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ top = SCM_VM_FRAME_SP (frame);
+ bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (bottom <= top)
+ ret = scm_cons (*bottom++, ret);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+extern SCM
+scm_c_vm_frame_prev (SCM frame)
+{
+ SCM *this_fp, *new_fp, *new_sp;
+ this_fp = SCM_VM_FRAME_FP (frame);
+ new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
+ if (new_fp)
+ { new_fp = RELOC (frame, new_fp);
+ new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
+ return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
+ new_fp, new_sp,
+ SCM_FRAME_RETURN_ADDRESS (this_fp),
+ SCM_VM_FRAME_OFFSET (frame));
+ }
+ else
+ return SCM_BOOL_F;
+}
+
+\f
+void
+scm_bootstrap_frames (void)
+{
+ scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
+ scm_set_smob_mark (scm_tc16_vm_frame, vm_frame_mark);
+ scm_set_smob_free (scm_tc16_vm_frame, vm_frame_free);
+ scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print);
+}
+
+void
+scm_init_frames (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "frames.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_FRAMES_H_
+#define _SCM_FRAMES_H_
+
+#include <libguile.h>
+#include "programs.h"
+
+\f
+/*
+ * VM frames
+ */
+
+/* VM Frame Layout
+ ---------------
+
+ | | <- fp + bp->nargs + bp->nlocs + 4
+ +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
+ | Return address |
+ | MV return address|
+ | Dynamic link |
+ | External link | <- fp + bp->nargs + bp->nlocs
+ | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
+ | Local variable 0 | <- fp + bp->nargs
+ | Argument 1 |
+ | Argument 0 | <- fp
+ | Program | <- fp - 1
+ +------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+ | |
+
+ As can be inferred from this drawing, it is assumed that
+ `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
+ assumed to be as long as SCM objects. */
+
+#define SCM_FRAME_DATA_ADDRESS(fp) \
+ (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4)
+#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
+
+#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
+#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
+
+#define SCM_FRAME_RETURN_ADDRESS(fp) \
+ (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
+#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
+ (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_DYNAMIC_LINK(fp) \
+ (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
+#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
+ ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl);
+#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0])
+#define SCM_FRAME_VARIABLE(fp,i) fp[i]
+#define SCM_FRAME_PROGRAM(fp) fp[-1]
+
+\f
+/*
+ * Heap frames
+ */
+
+extern scm_t_bits scm_tc16_vm_frame;
+
+struct scm_vm_frame
+{
+ SCM stack_holder;
+ SCM *fp;
+ SCM *sp;
+ scm_byte_t *ip;
+ scm_t_ptrdiff offset;
+};
+
+#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_frame, x)
+#define SCM_VM_FRAME_DATA(x) ((struct scm_vm_frame*)SCM_SMOB_DATA (x))
+#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
+#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
+#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
+#define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA(f)->ip
+#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
+#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
+
+/* FIXME rename scm_byte_t */
+extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+ scm_byte_t *ip, scm_t_ptrdiff offset);
+extern SCM scm_vm_frame_p (SCM obj);
+extern SCM scm_vm_frame_program (SCM frame);
+extern SCM scm_vm_frame_arguments (SCM frame);
+extern SCM scm_vm_frame_source (SCM frame);
+extern SCM scm_vm_frame_local_ref (SCM frame, SCM index);
+extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+extern SCM scm_vm_frame_return_address (SCM frame);
+extern SCM scm_vm_frame_mv_return_address (SCM frame);
+extern SCM scm_vm_frame_dynamic_link (SCM frame);
+extern SCM scm_vm_frame_external_link (SCM frame);
+extern SCM scm_vm_frame_stack (SCM frame);
+
+extern SCM scm_c_vm_frame_prev (SCM frame);
+
+extern void scm_bootstrap_frames (void);
+extern void scm_init_frames (void);
+
+#endif /* _SCM_FRAMES_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
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;
}
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
-#define DEFVAR(v, val) \
-{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
- scm_module_goops); }
-/* Temporary hack until we get the new module system */
-/*fixme* Should optimize by keeping track of the variable object itself */
-#define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
- (v), SCM_BOOL_F)))
-
-/* Fixme: Should use already interned symbols */
-
-#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
- a))
-#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
- a, b))
-#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
- a, b, c))
-#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
- a, b, c, d))
+/* this file is a mess. in theory, though, we shouldn't have many SCM references
+ -- most of the references should be to vars. */
+
+static SCM var_slot_unbound = SCM_BOOL_F;
+static SCM var_slot_missing = SCM_BOOL_F;
+static SCM var_compute_cpl = SCM_BOOL_F;
+static SCM var_no_applicable_method = SCM_BOOL_F;
+static SCM var_memoize_method_x = SCM_BOOL_F;
+static SCM var_change_class = SCM_BOOL_F;
+
+SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
+SCM_SYMBOL (sym_slot_missing, "slot-missing");
+SCM_SYMBOL (sym_compute_cpl, "compute-cpl");
+SCM_SYMBOL (sym_no_applicable_method, "no-applicable-method");
+SCM_SYMBOL (sym_memoize_method_x, "memoize-method!");
+SCM_SYMBOL (sym_change_class, "change-class");
+
+SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
+
+
+/* FIXME, exports should come from the scm file only */
+#define DEFVAR(v, val) \
+ { scm_module_define (scm_module_goops, (v), (val)); \
+ scm_module_export (scm_module_goops, scm_list_1 ((v))); \
+ }
+
/* Class redefinition protocol:
static int goops_loaded_p = 0;
static scm_t_rstate *goops_rstate;
-static SCM scm_goops_lookup_closure;
-
/* These variables are filled in by the object system when loaded. */
SCM scm_class_boolean, scm_class_char, scm_class_pair;
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
compute_cpl (SCM class)
{
if (goops_loaded_p)
- return CALL_GF1 ("compute-cpl", class);
+ return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class);
else
{
SCM supers = SCM_SLOT (class, scm_si_direct_supers);
{
slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
if (SCM_GOOPS_UNBOUNDP (slot_value))
- {
- SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp));
- set_slot_value (class,
- obj,
- SCM_CAR (get_n_set),
- scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
- }
+ set_slot_value (class,
+ obj,
+ SCM_CAR (get_n_set),
+ scm_call_0 (tmp));
}
}
}
#define FUNC_NAME s_scm_assert_bound
{
if (SCM_GOOPS_UNBOUNDP (value))
- return CALL_GF1 ("slot-unbound", obj);
+ return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
return value;
}
#undef FUNC_NAME
{
SCM value = SCM_SLOT (obj, scm_to_int (index));
if (SCM_GOOPS_UNBOUNDP (value))
- return CALL_GF1 ("slot-unbound", obj);
+ return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
return value;
}
#undef FUNC_NAME
code = SCM_CAR (access);
if (!SCM_CLOSUREP (code))
- return SCM_SUBRF (code) (obj);
+ return scm_call_1 (code, obj);
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
scm_list_1 (obj),
SCM_ENV (code));
if (scm_is_true (slotdef))
return get_slot_value (class, obj, slotdef);
else
- return CALL_GF3 ("slot-missing", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name);
}
static SCM
code = SCM_CADR (access);
if (!SCM_CLOSUREP (code))
- SCM_SUBRF (code) (obj, value);
+ scm_call_2 (code, obj, value);
else
{
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
if (scm_is_true (slotdef))
return set_slot_value (class, obj, slotdef, value);
else
- return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
+ return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name, value);
}
static SCM
res = get_slot_value_using_name (class, obj, slot_name);
if (SCM_GOOPS_UNBOUNDP (res))
- return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
return res;
}
#undef FUNC_NAME
res = get_slot_value_using_name (class, obj, slot_name);
if (SCM_GOOPS_UNBOUNDP (res))
- return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
return res;
}
#undef FUNC_NAME
static SCM
purgatory (void *args)
{
- return scm_apply_0 (GETVAR (scm_sym_change_class),
+ return scm_apply_0 (SCM_VARIABLE_REF (var_change_class),
SCM_PACK ((scm_t_bits) args));
}
{
if (find_method_p)
return SCM_BOOL_F;
- CALL_GF2 ("no-applicable-method", gf, save);
+ scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method), gf, save);
/* if we are here, it's because no-applicable-method hasn't signaled an error */
return SCM_BOOL_F;
}
SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
if (scm_is_true (cmethod))
return cmethod;
- /*fixme* Use scm_apply */
- return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
+
+ if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x)))
+ var_memoize_method_x =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_memoize_method_x));
+
+ return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR (args), x);
}
SCM
SCM_KEYWORD (k_setter, "setter");
SCM_KEYWORD (k_specializers, "specializers");
SCM_KEYWORD (k_procedure, "procedure");
+SCM_KEYWORD (k_formals, "formals");
+SCM_KEYWORD (k_body, "body");
+SCM_KEYWORD (k_make_procedure, "make-procedure");
SCM_KEYWORD (k_dsupers, "dsupers");
SCM_KEYWORD (k_slots, "slots");
SCM_KEYWORD (k_gf, "generic-function");
scm_i_get_keyword (k_procedure,
args,
len - 1,
- SCM_EOL,
+ SCM_BOOL_F,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
+ SCM_SET_SLOT (z, scm_si_formals,
+ scm_i_get_keyword (k_formals,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_body,
+ scm_i_get_keyword (k_body,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_make_procedure,
+ scm_i_get_keyword (k_make_procedure,
+ args,
+ len - 1,
+ SCM_BOOL_F,
+ FUNC_NAME));
}
else
{
create_standard_classes (void)
{
SCM slots;
- SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
+ SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
scm_from_locale_symbol ("specializers"),
sym_procedure,
- scm_from_locale_symbol ("code-table"));
+ scm_from_locale_symbol ("code-table"),
+ scm_from_locale_symbol ("formals"),
+ scm_from_locale_symbol ("body"),
+ scm_from_locale_symbol ("make-procedure"),
+ SCM_UNDEFINED);
SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
k_init_keyword,
k_slot_definition));
/* Only define name if doesn't already exist. */
if (!SCM_GOOPS_UNBOUNDP (name)
- && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
+ && scm_is_false (scm_module_variable (scm_module_goops, name)))
DEFVAR (name, class);
return class;
}
{
goops_loaded_p = 1;
var_compute_applicable_methods =
- scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
- SCM_BOOL_F);
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_compute_applicable_methods));
+ var_slot_unbound =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_slot_unbound));
+ var_slot_missing =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_slot_missing));
+ var_compute_cpl =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_compute_cpl));
+ var_no_applicable_method =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_no_applicable_method));
+ var_change_class =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_change_class));
setup_extended_primitive_generics ();
return SCM_UNSPECIFIED;
}
scm_init_goops_builtins (void)
{
scm_module_goops = scm_current_module ();
- scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
/* Not really necessary right now, but who knows...
*/
scm_permanent_object (scm_module_goops);
- scm_permanent_object (scm_goops_lookup_closure);
scm_components = scm_permanent_object (scm_make_weak_key_hash_table
(scm_from_int (37)));
#define scm_si_generic_function 0 /* offset of gf slot in a <method> */
#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
-
#define scm_si_procedure 2 /* offset of proc. slot in a <method> */
#define scm_si_code_table 3 /* offset of code. slot in a <method> */
+#define scm_si_formals 4 /* offset of form. slot in a <method> */
+#define scm_si_body 5 /* offset of body slot in a <method> */
+#define scm_si_make_procedure 6 /* offset of makep.slot in a <method> */
/* C interface */
SCM_API SCM scm_class_boolean;
#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"
/* 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))
scm_init_rw ();
scm_init_extensions ();
+ scm_bootstrap_vm ();
+
atexit (cleanup_for_exit);
scm_load_startup_files ();
}
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "instructions.h"
+
+struct scm_instruction {
+ 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 */
+ SCM symname; /* filled in later */
+};
+
+#define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar) \
+ do { \
+ cvar = scm_lookup_instruction_by_name (var); \
+ SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P"); \
+ } while (0)
+
+
+static struct scm_instruction*
+fetch_instruction_table ()
+{
+ static struct scm_instruction *table = NULL;
+
+ if (SCM_UNLIKELY (!table))
+ {
+ size_t bytes = scm_op_last * sizeof(struct scm_instruction);
+ int i;
+ table = malloc (bytes);
+ memset (table, 0, bytes);
+#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
+ for (i = 0; i < scm_op_last; i++)
+ {
+ table[i].opcode = i;
+ if (table[i].name)
+ table[i].symname = scm_from_locale_symbol (table[i].name);
+ else
+ table[i].symname = SCM_BOOL_F;
+ }
+ }
+ return table;
+}
+
+static struct scm_instruction *
+scm_lookup_instruction_by_name (SCM name)
+{
+ static SCM instructions_by_name = SCM_BOOL_F;
+ struct scm_instruction *table = fetch_instruction_table ();
+ SCM op;
+
+ if (SCM_UNLIKELY (SCM_FALSEP (instructions_by_name)))
+ {
+ int i;
+ instructions_by_name = scm_make_hash_table (SCM_I_MAKINUM (scm_op_last));
+ for (i = 0; i < scm_op_last; i++)
+ if (scm_is_true (table[i].symname))
+ scm_hashq_set_x (instructions_by_name, table[i].symname,
+ SCM_I_MAKINUM (i));
+ instructions_by_name = scm_permanent_object (instructions_by_name);
+ }
+
+ op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
+ if (SCM_I_INUMP (op))
+ return &table[SCM_I_INUM (op)];
+
+ return NULL;
+}
+
+
+/* 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 = fetch_instruction_table (); ip->opcode != scm_op_last; ip++)
+ if (ip->name)
+ list = scm_cons (ip->symname, 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_lookup_instruction_by_name (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_length
+{
+ struct scm_instruction *ip;
+ SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+ return SCM_I_MAKINUM (ip->len);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_pops
+{
+ struct scm_instruction *ip;
+ SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+ return SCM_I_MAKINUM (ip->npop);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_pushes
+{
+ struct scm_instruction *ip;
+ SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+ return SCM_I_MAKINUM (ip->npush);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_to_opcode
+{
+ struct scm_instruction *ip;
+ SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+ return SCM_I_MAKINUM (ip->opcode);
+}
+#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 opcode;
+ SCM ret = SCM_BOOL_F;
+
+ SCM_MAKE_VALIDATE (1, op, I_INUMP);
+ opcode = SCM_I_INUM (op);
+
+ if (opcode < scm_op_last)
+ ret = fetch_instruction_table ()[opcode].symname;
+
+ if (scm_is_false (ret))
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");
+
+ return ret;
+}
+#undef FUNC_NAME
+
+void
+scm_bootstrap_instructions (void)
+{
+}
+
+void
+scm_init_instructions (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "instructions.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_INSTRUCTIONS_H_
+#define _SCM_INSTRUCTIONS_H_
+
+#include <libguile.h>
+
+#define SCM_VM_NUM_INSTRUCTIONS (1<<7)
+#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)
+
+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 = SCM_VM_NUM_INSTRUCTIONS
+};
+
+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:
+*/
#include "libguile/load.h"
#include "libguile/fluids.h"
+#include "libguile/vm.h" /* for load-compiled/vm */
+
#include <sys/types.h>
#include <sys/stat.h>
/* 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),
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");
}
+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"
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);
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. */
{
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;
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
"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
= 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 ();
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);
#include "libguile/deprecation.h"
#include "libguile/validate.h"
+#include "libguile/programs.h"
#include "libguile/macros.h"
#include "libguile/private-options.h"
|| 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);
"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
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)
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))
}
#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
* 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"
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);
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <assert.h>
+
+#include "vm-bootstrap.h"
+#include "programs.h"
+#include "objcodes.h"
+
+/* nb, the length of the header should be a multiple of 8 bytes */
+#define OBJCODE_COOKIE "GOOF-0.5"
+
+\f
+/*
+ * Objcode type
+ */
+
+scm_t_bits scm_tc16_objcode;
+
+static SCM
+make_objcode_by_mmap (int fd)
+#define FUNC_NAME "make_objcode_by_mmap"
+{
+ int ret;
+ char *addr;
+ struct stat st;
+ SCM sret = SCM_BOOL_F;
+ struct scm_objcode *data;
+
+ ret = fstat (fd, &st);
+ if (ret < 0)
+ SCM_SYSERROR;
+
+ if (st.st_size <= sizeof (struct scm_objcode) + 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;
+
+ data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
+
+ if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
+ scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
+ SCM_LIST2 (scm_from_size_t (st.st_size),
+ scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
+
+ SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
+ SCM_PACK (SCM_BOOL_F), fd);
+ SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
+
+ /* FIXME: we leak ourselves and the file descriptor. but then again so does
+ dlopen(). */
+ return scm_permanent_object (sret);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
+#define FUNC_NAME "make-objcode-slice"
+{
+ struct scm_objcode *data, *parent_data;
+ SCM ret;
+
+ SCM_VALIDATE_OBJCODE (1, parent);
+ parent_data = SCM_OBJCODE_DATA (parent);
+
+ if (ptr < parent_data->base
+ || ptr >= (parent_data->base + parent_data->len + parent_data->metalen
+ - sizeof (struct scm_objcode)))
+ scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
+ SCM_LIST4 (scm_from_ulong ((ulong)ptr),
+ scm_from_ulong ((ulong)parent_data->base),
+ scm_from_uint32 (parent_data->len),
+ scm_from_uint32 (parent_data->metalen)));
+
+ data = (struct scm_objcode*)ptr;
+ if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
+ abort ();
+
+ SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
+ SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
+ return ret;
+}
+#undef FUNC_NAME
+
+static SCM
+objcode_mark (SCM obj)
+{
+ return SCM_SMOB_OBJECT_2 (obj);
+}
+
+\f
+/*
+ * Scheme interface
+ */
+
+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_objcode_meta, "objcode-meta", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_meta
+{
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ if (SCM_OBJCODE_META_LEN (objcode) == 0)
+ return SCM_BOOL_F;
+ else
+ return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
+ + SCM_OBJCODE_LEN (objcode)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
+ (SCM bytecode),
+ "")
+#define FUNC_NAME s_scm_bytecode_to_objcode
+{
+ size_t size;
+ ssize_t increment;
+ scm_t_array_handle handle;
+ const scm_t_uint8 *c_bytecode;
+ struct scm_objcode *data;
+ SCM objcode;
+
+ if (scm_is_false (scm_u8vector_p (bytecode)))
+ scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
+
+ c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+ data = (struct scm_objcode*)c_bytecode;
+ SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
+ scm_array_handle_release (&handle);
+
+ SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
+ if (data->len + data->metalen != (size - sizeof (*data)))
+ scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
+ SCM_LIST2 (scm_from_size_t (size),
+ scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
+ assert (increment == 1);
+ SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
+
+ /* foolishly, we assume that as long as bytecode is around, that c_bytecode
+ will be of the same length; perhaps a bad assumption? */
+
+ 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_bytecode, "objcode->bytecode", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_to_bytecode
+{
+ scm_t_uint8 *u8vector;
+ scm_t_uint32 len;
+
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
+ /* FIXME: Is `gc_malloc' ok here? */
+ u8vector = scm_gc_malloc (len, "objcode-u8vector");
+ memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
+
+ return scm_take_u8vector (u8vector, len);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
+ (SCM objcode, SCM port),
+ "")
+#define FUNC_NAME s_scm_write_objcode
+{
+ SCM_VALIDATE_OBJCODE (1, objcode);
+ SCM_VALIDATE_OUTPUT_PORT (2, port);
+
+ scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
+ scm_c_write (port, SCM_OBJCODE_DATA (objcode),
+ sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+void
+scm_bootstrap_objcodes (void)
+{
+ scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
+ scm_set_smob_mark (scm_tc16_objcode, objcode_mark);
+}
+
+void
+scm_init_objcodes (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "objcodes.x"
+#endif
+
+ scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
+ scm_c_define ("byte-order", scm_from_uint16 (__BYTE_ORDER));
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_OBJCODES_H_
+#define _SCM_OBJCODES_H_
+
+#include <libguile.h>
+
+/* objcode data should be directly mappable to this C structure. */
+struct scm_objcode {
+ scm_t_uint8 nargs;
+ scm_t_uint8 nrest;
+ scm_t_uint8 nlocs;
+ scm_t_uint8 nexts;
+ scm_t_uint32 len; /* the maximum index of base[] */
+ scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of
+ base[] for metadata */
+ scm_t_uint8 base[0];
+};
+
+#define SCM_F_OBJCODE_IS_MMAP (1<<0)
+#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
+#define SCM_F_OBJCODE_IS_SLICE (1<<2)
+
+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_LEN(x) (SCM_OBJCODE_DATA (x)->len)
+#define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen)
+#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x))
+#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs)
+#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest)
+#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs)
+#define SCM_OBJCODE_NEXTS(x) (SCM_OBJCODE_DATA (x)->nexts)
+#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
+
+#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
+#define SCM_OBJCODE_IS_U8VECTOR(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_U8VECTOR)
+#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
+
+SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
+extern SCM scm_load_objcode (SCM file);
+extern SCM scm_objcode_p (SCM obj);
+extern SCM scm_objcode_meta (SCM objcode);
+extern SCM scm_bytecode_to_objcode (SCM bytecode);
+extern SCM scm_objcode_to_bytecode (SCM objcode);
+extern SCM scm_write_objcode (SCM objcode, SCM port);
+
+extern void scm_bootstrap_objcodes (void);
+extern void scm_init_objcodes (void);
+
+#endif /* _SCM_OBJCODES_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
+#include "libguile/programs.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/objects.h"
z = SCM_CDR (z);
}
while (j-- && !scm_is_null (ls));
- /* Fewer arguments than specifiers => CAR != ENV */
- if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
+ /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */
+ if (!scm_is_pair (z)
+ || (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z))))
return z;
next_method:
i = (i + 1) & mask;
scm_apply_generic (SCM gf, SCM args)
{
SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
- return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
- SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
- args,
- SCM_CMETHOD_ENV (cmethod)));
+ if (SCM_PROGRAM_P (cmethod))
+ return scm_vm_apply (scm_the_vm (), cmethod, args);
+ else if (scm_is_pair (cmethod))
+ return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+ args,
+ SCM_CMETHOD_ENV (cmethod)));
+ else
+ return scm_apply (cmethod, args, SCM_EOL);
}
SCM
#include "libguile/validate.h"
#include "libguile/procs.h"
+#include "libguile/procprop.h"
+#include "libguile/objcodes.h"
+#include "libguile/programs.h"
\f
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;
"with the associated setter @var{setter}.")
#define FUNC_NAME s_scm_make_procedure_with_setter
{
+ SCM name, ret;
SCM_VALIDATE_PROC (1, procedure);
SCM_VALIDATE_PROC (2, setter);
- return scm_double_cell (scm_tc7_pws,
- SCM_UNPACK (procedure),
- SCM_UNPACK (setter), 0);
+ ret = scm_double_cell (scm_tc7_pws,
+ SCM_UNPACK (procedure),
+ SCM_UNPACK (setter), 0);
+ /* don't use procedure_name, because don't care enough to do a reverse
+ lookup */
+ switch (SCM_TYP7 (procedure)) {
+ case scm_tcs_subrs:
+ name = SCM_SNAME (procedure);
+ break;
+ default:
+ name = scm_procedure_property (procedure, scm_sym_name);
+ break;
+ }
+ if (scm_is_true (name))
+ scm_set_procedure_property_x (ret, scm_sym_name, name);
+ return ret;
}
#undef FUNC_NAME
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "instructions.h"
+#include "modules.h"
+#include "programs.h"
+#include "procprop.h" // scm_sym_name
+#include "srcprop.h" // scm_sym_filename
+#include "vm.h"
+
+\f
+scm_t_bits scm_tc16_program;
+
+static SCM write_program = SCM_BOOL_F;
+
+SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
+ (SCM objcode, SCM objtable, SCM external),
+ "")
+#define FUNC_NAME s_scm_make_program
+{
+ SCM_VALIDATE_OBJCODE (1, objcode);
+ if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
+ objtable = SCM_BOOL_F;
+ else if (scm_is_true (objtable))
+ SCM_VALIDATE_VECTOR (2, objtable);
+ if (SCM_UNLIKELY (SCM_UNBNDP (external)))
+ external = SCM_EOL;
+ else
+ /* FIXME: currently this test is quite expensive (can be 2-3% of total
+ execution time in programs that make many closures). We could remove it,
+ yes, but we'd get much better gains if we used some other method, like
+ just capturing the variables that we need instead of all heap-allocated
+ variables. Dunno. Keeping the check for now, as it's a user-callable
+ function, and inlining the op in the vm's make-closure operation. */
+ SCM_VALIDATE_LIST (3, external);
+
+ SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
+}
+#undef FUNC_NAME
+
+static SCM
+program_mark (SCM obj)
+{
+ if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
+ scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
+ if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj)))
+ scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
+ return SCM_PROGRAM_OBJCODE (obj);
+}
+
+static SCM
+program_apply (SCM program, SCM args)
+{
+ return scm_vm_apply (scm_the_vm (), program, args);
+}
+
+static SCM
+program_apply_0 (SCM program)
+{
+ return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
+}
+
+static SCM
+program_apply_1 (SCM program, SCM a)
+{
+ return scm_c_vm_run (scm_the_vm (), program, &a, 1);
+}
+
+static SCM
+program_apply_2 (SCM program, SCM a, SCM b)
+{
+ SCM args[2];
+ args[0] = a;
+ args[1] = b;
+ return scm_c_vm_run (scm_the_vm (), program, args, 2);
+}
+
+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;
+}
+
+\f
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_program_p
+{
+ return SCM_BOOL (SCM_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_base
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_arity
+{
+ struct scm_objcode *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_objects, "program-objects", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_objects
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_OBJTABLE (program);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_module
+{
+ SCM objs;
+ SCM_VALIDATE_PROGRAM (1, program);
+ objs = SCM_PROGRAM_OBJTABLE (program);
+ return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_meta
+{
+ SCM metaobj;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
+ if (scm_is_true (metaobj))
+ return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_bindings
+{
+ SCM meta;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ meta = scm_program_meta (program);
+ if (scm_is_false (meta))
+ return SCM_BOOL_F;
+
+ return scm_car (scm_call_0 (meta));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_sources
+{
+ SCM meta, sources, ret, filename;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ meta = scm_program_meta (program);
+ if (scm_is_false (meta))
+ return SCM_EOL;
+
+ filename = SCM_BOOL_F;
+ ret = SCM_EOL;
+ for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
+ sources = scm_cdr (sources))
+ {
+ SCM x = scm_car (sources);
+ if (scm_is_pair (x))
+ {
+ if (scm_is_number (scm_car (x)))
+ {
+ SCM addr = scm_car (x);
+ ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
+ ret);
+ }
+ else if (scm_is_eq (scm_car (x), scm_sym_filename))
+ filename = scm_cdr (x);
+ }
+ }
+ return scm_reverse_x (ret, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_properties
+{
+ SCM meta;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ meta = scm_program_meta (program);
+ if (scm_is_false (meta))
+ return SCM_EOL;
+
+ return scm_cddr (scm_call_0 (meta));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_name
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return scm_assq_ref (scm_program_properties (program), scm_sym_name);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
+ (SCM program, SCM ip),
+ "")
+#define FUNC_NAME s_scm_program_source
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return scm_c_program_source (program, scm_to_size_t (ip));
+}
+#undef FUNC_NAME
+
+extern SCM
+scm_c_program_source (SCM program, size_t ip)
+{
+ SCM sources, source = SCM_BOOL_F;
+
+ for (sources = scm_program_sources (program);
+ !scm_is_null (sources)
+ && scm_to_size_t (scm_caar (sources)) <= ip;
+ sources = scm_cdr (sources))
+ source = scm_car (sources);
+
+ return source; /* (addr . (filename . (line . column))) */
+}
+
+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_EXTERNALS (program);
+}
+#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_EXTERNALS (program) = external;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
+ (SCM program),
+ "Return a @var{program}'s object code.")
+#define FUNC_NAME s_scm_program_objcode
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ return SCM_PROGRAM_OBJCODE (program);
+}
+#undef FUNC_NAME
+
+
+\f
+void
+scm_bootstrap_programs (void)
+{
+ scm_tc16_program = scm_make_smob_type ("program", 0);
+ scm_set_smob_mark (scm_tc16_program, program_mark);
+ scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
+ scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_0 = program_apply_0;
+ scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
+ scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
+ 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:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_PROGRAMS_H_
+#define _SCM_PROGRAMS_H_
+
+#include <libguile.h>
+#include <libguile/objcodes.h>
+
+/*
+ * Programs
+ */
+
+typedef unsigned char scm_byte_t;
+
+extern scm_t_bits scm_tc16_program;
+
+#define SCM_F_PROGRAM_IS_BOOT (1<<0)
+
+#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
+#define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x))
+#define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x))
+#define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x))
+#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
+#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
+
+extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
+
+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_bindings (SCM program);
+extern SCM scm_program_sources (SCM program);
+extern SCM scm_program_source (SCM program, SCM ip);
+extern SCM scm_program_properties (SCM program);
+extern SCM scm_program_name (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_objcode (SCM program);
+
+extern SCM scm_c_program_source (SCM program, size_t ip);
+
+extern void scm_bootstrap_programs (void);
+extern void scm_init_programs (void);
+
+#endif /* _SCM_PROGRAMS_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
#include "libguile/modules.h"
#include "libguile/root.h"
#include "libguile/strings.h"
+#include "libguile/vm.h" /* to capture vm stacks */
+#include "libguile/frames.h" /* vm frames */
+#include "libguile/instructions.h" /* scm_op_halt */
#include "libguile/validate.h"
#include "libguile/stacks.h"
#define RELOC_FRAME(ptr, offset) \
((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
-
/* Count number of debug info frames on a stack, beginning with
* DFRAME. OFFSET is used for relocation of pointers when the stack
* is read from a continuation.
*/
-static scm_t_bits
-stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- SCM *id, int *maxp)
+static long
+stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
+ SCM *id)
{
long n;
- long max_depth = SCM_BACKTRACE_MAXDEPTH;
for (n = 0;
- dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
+ dframe && !SCM_VOIDFRAMEP (*dframe);
dframe = RELOC_FRAME (dframe->prev, offset))
{
if (SCM_EVALFRAMEP (*dframe))
if ((((info - vect) & 1) == 0)
&& SCM_OVERFLOWP (*dframe)
&& !SCM_UNBNDP (info[1].a.proc))
- ++n;
+ ++n;
}
+ else if (SCM_APPLYFRAMEP (*dframe))
+ {
+ scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+ if (SCM_PROGRAM_P (vect[0].a.proc))
+ {
+ if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc))
+ /* Programs can end up in the debug stack via deval; but we just
+ ignore those, because we know that the debugging VM engine
+ pushes one dframe per invocation, with the boot program as
+ the proc, so we only count those. */
+ continue;
+ /* count vmframe back to previous boot frame */
+ for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe))
+ {
+ if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
+ ++n;
+ else
+ { /* skip boot frame, cut out of the vm backtrace */
+ vmframe = scm_c_vm_frame_prev (vmframe);
+ break;
+ }
+ }
+ }
+ else if (scm_is_eq (vect[0].a.proc, scm_f_gsubr_apply))
+ /* Skip gsubr apply frames. */
+ continue;
+ else
+ ++n; /* increment for non-program apply frame */
+ }
else
++n;
}
if (dframe && SCM_VOIDFRAMEP (*dframe))
*id = RELOC_INFO(dframe->vect, offset)[0].id;
- else if (dframe)
- *maxp = 1;
return n;
}
static scm_t_bits
read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- long n, scm_t_info_frame *iframes)
+ SCM vmframe, long n, scm_t_info_frame *iframes)
{
scm_t_info_frame *iframe = iframes;
scm_t_debug_info *info, *vect;
else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply))
/* Skip gsubr apply frames. */
continue;
+ else if (SCM_PROGRAM_P (iframe->proc))
+ {
+ if (!SCM_PROGRAM_IS_BOOT (iframe->proc))
+ /* Programs can end up in the debug stack via deval; but we just
+ ignore those, because we know that the debugging VM engine
+ pushes one dframe per invocation, with the boot program as
+ the proc, so we only count those. */
+ continue;
+ for (; scm_is_true (vmframe);
+ vmframe = scm_c_vm_frame_prev (vmframe))
+ {
+ if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
+ { /* skip boot frame, back to interpreted frames */
+ vmframe = scm_c_vm_frame_prev (vmframe);
+ break;
+ }
+ else
+ {
+ /* Oh dear, oh dear, oh dear. */
+ iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC;
+ iframe->source = scm_vm_frame_source (vmframe);
+ iframe->proc = scm_vm_frame_program (vmframe);
+ iframe->args = scm_vm_frame_arguments (vmframe);
+ ++iframe;
+ if (--n == 0)
+ goto quit;
+ }
+ }
+ }
else
- {
- NEXT_FRAME (iframe, n, quit);
- }
+ {
+ NEXT_FRAME (iframe, n, quit);
+ }
quit:
if (iframe > iframes)
(iframe - 1) -> flags |= SCM_FRAMEF_REAL;
int maxp;
scm_t_debug_frame *dframe;
scm_t_info_frame *iframe;
+ SCM vmframe;
long offset = 0;
SCM stack, id;
SCM inner_cut, outer_cut;
scm_make_stack was given. */
if (scm_is_eq (obj, SCM_BOOL_T))
{
+ struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
dframe = scm_i_last_debug_frame ();
+ vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
}
else if (SCM_DEBUGOBJP (obj))
{
dframe = SCM_DEBUGOBJ_FRAME (obj);
+ vmframe = SCM_BOOL_F;
+ }
+ else if (SCM_VM_FRAME_P (obj))
+ {
+ dframe = NULL;
+ vmframe = obj;
}
else if (SCM_CONTINUATIONP (obj))
{
scm_t_contregs *cont = SCM_CONTREGS (obj);
offset = cont->offset;
dframe = RELOC_FRAME (cont->dframe, offset);
+ if (!scm_is_null (cont->vm_conts))
+ { SCM vm_cont;
+ struct scm_vm_cont *data;
+ vm_cont = scm_cdr (scm_car (cont->vm_conts));
+ data = SCM_VM_CONT_DATA (vm_cont);
+ vmframe = scm_c_make_vm_frame (vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ip,
+ data->reloc);
+ } else
+ vmframe = SCM_BOOL_F;
}
else
{
(SCM_BACKTRACE_MAXDEPTH). */
id = SCM_BOOL_F;
maxp = 0;
- n = stack_depth (dframe, offset, &id, &maxp);
+ n = stack_depth (dframe, offset, vmframe, &id);
+ /* FIXME: redo maxp? */
size = n * SCM_FRAME_N_SLOTS;
/* Make the stack object. */
SCM_STACK (stack) -> id = id;
iframe = &SCM_STACK (stack) -> tail[0];
SCM_STACK (stack) -> frames = iframe;
+ SCM_STACK (stack) -> length = n;
/* Translate the current chain of stack frames into debugging information. */
- n = read_frames (dframe, offset, n, iframe);
- SCM_STACK (stack) -> length = n;
+ n = read_frames (dframe, offset, vmframe, n, iframe);
+ if (n != SCM_STACK (stack)->length)
+ {
+ scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ());
+ SCM_STACK (stack)->length = n;
+ }
/* Narrow the stack according to the arguments given to scm_make_stack. */
SCM_VALIDATE_REST_ARGUMENT (args);
n = SCM_STACK (stack) -> length;
}
+ if (n > 0 && maxp)
+ iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+
if (n > 0)
- {
- if (maxp)
- iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
- return stack;
- }
+ return stack;
else
return SCM_BOOL_F;
}
scm_gc_mark (t->dynwinds);
scm_gc_mark (t->active_asyncs);
scm_gc_mark (t->continuation_root);
+ scm_gc_mark (t->vm);
return t->dynamic_state;
}
scm_gc_register_collectable_memory (t, sizeof (scm_i_thread), "thread");
t->continuation_root = scm_cons (t->handle, SCM_EOL);
t->continuation_base = t->base;
+ t->vm = SCM_BOOL_F;
if (scm_is_true (parent))
t->dynamic_state = scm_make_dynamic_state (parent);
SCM_STACKITEM *continuation_base;
/* For keeping track of the stack and registers. */
+ SCM vm;
SCM_STACKITEM *base;
SCM_STACKITEM *top;
jmp_buf regs;
#include "libguile/throw.h"
#include "libguile/init.h"
#include "libguile/strings.h"
+#include "libguile/vm.h"
#include "libguile/private-options.h"
struct jmp_buf_and_retval jbr;
SCM jmpbuf;
SCM answer;
+ SCM vm;
+ SCM *sp = NULL, *fp = NULL; /* to reset the vm */
struct pre_unwind_data pre_unwind;
+ vm = scm_the_vm ();
+ if (SCM_NFALSEP (vm))
+ {
+ sp = SCM_VM_DATA (vm)->sp;
+ fp = SCM_VM_DATA (vm)->fp;
+ }
+
jmpbuf = make_jmpbuf ();
answer = SCM_EOL;
scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
throw_tag = jbr.throw_tag;
jbr.throw_tag = SCM_EOL;
jbr.retval = SCM_EOL;
+ if (SCM_NFALSEP (vm))
+ {
+ SCM_VM_DATA (vm)->sp = sp;
+ SCM_VM_DATA (vm)->fp = fp;
+#ifdef VM_ENABLE_STACK_NULLING
+ /* see vm.c -- you'll have to enable this manually */
+ memset (sp + 1, 0,
+ (SCM_VM_DATA (vm)->stack_size
+ - (sp + 1 - SCM_VM_DATA (vm)->stack_base)) * sizeof(SCM));
+#endif
+ }
+ else if (SCM_NFALSEP ((vm = scm_the_vm ())))
+ {
+ /* oof, it's possible this catch was called before the vm was
+ booted... yick. anyway, try to reset the vm stack. */
+ SCM_VM_DATA (vm)->sp = SCM_VM_DATA (vm)->stack_base - 1;
+ SCM_VM_DATA (vm)->fp = NULL;
+#ifdef VM_ENABLE_STACK_NULLING
+ /* see vm.c -- you'll have to enable this manually */
+ memset (SCM_VM_DATA (vm)->stack_base, 0,
+ SCM_VM_DATA (vm)->stack_size * sizeof(SCM));
+#endif
+ }
+
answer = handler (handler_data, throw_tag, throw_args);
}
else
#define SCM_VALIDATE_VECTOR_LEN(pos, v, len) \
do { \
- SCM_ASSERT (SCM_VECTORP (v) && len == SCM_VECTOR_LENGTH (v), v, pos, FUNC_NAME); \
+ SCM_ASSERT (scm_is_vector (v) && len == scm_c_vector_length (v), v, pos, FUNC_NAME); \
} while (0)
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_VM_BOOTSTRAP_H_
+#define _SCM_VM_BOOTSTRAP_H_
+
+extern void scm_bootstrap_vm (void);
+
+#endif /* _SCM_VM_BOOTSTRAP_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* This file is included in vm.c multiple times */
+
+#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
+#define VM_USE_HOOKS 0 /* Various hooks */
+#define VM_USE_CLOCK 0 /* Bogoclock */
+#define VM_CHECK_EXTERNAL 1 /* Check external link */
+#define VM_CHECK_OBJECT 1 /* Check object table */
+#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */
+#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
+#define VM_USE_HOOKS 1
+#define VM_USE_CLOCK 1
+#define VM_CHECK_EXTERNAL 1
+#define VM_CHECK_OBJECT 1
+#define VM_PUSH_DEBUG_FRAMES 1
+#else
+#error unknown debug engine VM_ENGINE
+#endif
+
+#include "vm-engine.h"
+
+
+static SCM
+VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
+{
+ /* 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_objcode *bp = NULL; /* program base pointer */
+ SCM external = SCM_EOL; /* external environment */
+ SCM *objects = NULL; /* constant objects */
+ size_t object_count = 0; /* length of OBJECTS */
+ SCM *stack_base = vp->stack_base; /* stack base address */
+ SCM *stack_limit = vp->stack_limit; /* stack limit address */
+
+ /* Internal variables */
+ int nvalues = 0;
+ long start_time = scm_c_get_internal_run_time ();
+ SCM finish_args; /* used both for returns: both in error
+ and normal situations */
+#if VM_USE_HOOKS
+ SCM hook_args = SCM_EOL;
+#endif
+
+#ifdef HAVE_LABELS_AS_VALUES
+ static void **jump_table = NULL;
+#endif
+
+#if VM_PUSH_DEBUG_FRAMES
+ scm_t_debug_frame debug;
+ scm_t_debug_info debug_vect_body;
+ debug.status = SCM_VOIDFRAME;
+#endif
+
+#ifdef HAVE_LABELS_AS_VALUES
+ if (SCM_UNLIKELY (!jump_table))
+ {
+ int i;
+ jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*));
+ for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
+ jump_table[i] = &&vm_error_bad_instruction;
+#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 */
+ program = vm_make_boot_program (nargs);
+
+#if VM_PUSH_DEBUG_FRAMES
+ debug.prev = scm_i_last_debug_frame ();
+ debug.status = SCM_APPLYFRAME;
+ debug.vect = &debug_vect_body;
+ debug.vect[0].a.proc = program; /* the boot program */
+ debug.vect[0].a.args = SCM_EOL;
+ scm_i_set_last_debug_frame (&debug);
+#endif
+
+ /* Initial frame */
+ CACHE_REGISTER ();
+ CACHE_PROGRAM ();
+ PUSH (program);
+ NEW_FRAME ();
+
+ /* Initial arguments */
+ PUSH (prog);
+ if (SCM_UNLIKELY (sp + nargs >= stack_limit))
+ goto vm_error_too_many_args;
+ while (nargs--)
+ PUSH (*argv++);
+ }
+
+ /* Let's go! */
+ BOOT_HOOK ();
+ NEXT;
+
+#ifndef HAVE_LABELS_AS_VALUES
+ vm_start:
+ switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
+#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
+ default:
+ goto vm_error_bad_instruction;
+ }
+#endif
+
+
+ vm_done:
+ SYNC_ALL ();
+#if VM_PUSH_DEBUG_FRAMES
+ scm_i_set_last_debug_frame (debug.prev);
+#endif
+ return finish_args;
+
+ /* Errors */
+ {
+ SCM err_msg;
+
+ vm_error_bad_instruction:
+ err_msg = scm_from_locale_string ("VM: Bad instruction: ~A");
+ finish_args = SCM_LIST1 (scm_from_uchar (ip[-1]));
+ goto vm_error;
+
+ 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");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_too_many_args:
+ err_msg = scm_from_locale_string ("VM: Too many arguments");
+ finish_args = SCM_LIST1 (scm_from_int (nargs));
+ goto vm_error;
+
+ vm_error_wrong_num_args:
+ /* nargs and program are valid */
+ SYNC_ALL ();
+ scm_wrong_num_args (program);
+ /* shouldn't get here */
+ goto vm_error;
+
+ vm_error_wrong_type_apply:
+ err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
+ "[IP offset: ~a]");
+ finish_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");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_stack_underflow:
+ err_msg = scm_from_locale_string ("VM: Stack underflow");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_improper_list:
+ err_msg = scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A");
+ goto vm_error;
+
+ vm_error_not_a_pair:
+ SYNC_ALL ();
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "pair");
+ /* shouldn't get here */
+ goto vm_error;
+
+ vm_error_no_values:
+ err_msg = scm_from_locale_string ("VM: 0-valued return");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_not_enough_values:
+ err_msg = scm_from_locale_string ("VM: Not enough values for mv-bind");
+ finish_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");
+ finish_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+#if VM_CHECK_EXTERNAL
+ vm_error_external:
+ err_msg = scm_from_locale_string ("VM: Invalid external access");
+ finish_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");
+ finish_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+ vm_error:
+ SYNC_ALL ();
+
+ scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, finish_args), 1);
+ }
+
+ abort (); /* never reached */
+}
+
+#undef VM_USE_HOOKS
+#undef VM_USE_CLOCK
+#undef VM_CHECK_EXTERNAL
+#undef VM_CHECK_OBJECT
+#undef VM_PUSH_DEBUG_FRAMES
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* This file is included in vm_engine.c */
+
+\f
+/*
+ * 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__
+/* gcc on lenny actually crashes if we allocate these variables in registers.
+ hopefully this is the only one of these. */
+#if !(__GNUC__==4 && __GNUC_MINOR__==1 && __GNUC_PATCHLEVEL__==2)
+#define IP_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define FP_REG
+#endif
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define IP_REG asm("26")
+#define SP_REG asm("27")
+#define FP_REG asm("28")
+#endif
+#ifdef __hppa__
+#define IP_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define FP_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define IP_REG asm("a5")
+#define SP_REG asm("a4")
+#define FP_REG
+#endif
+#ifdef __arm__
+#define IP_REG asm("r9")
+#define SP_REG asm("r8")
+#define FP_REG asm("r7")
+#endif
+#endif
+
+#ifndef IP_REG
+#define IP_REG
+#endif
+#ifndef SP_REG
+#define SP_REG
+#endif
+#ifndef FP_REG
+#define FP_REG
+#endif
+
+\f
+/*
+ * Cache/Sync
+ */
+
+#ifdef VM_ENABLE_ASSERTIONS
+# define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort()
+#else
+# define ASSERT(condition)
+#endif
+
+
+#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 VM_ENABLE_PARANOID_ASSERTIONS
+#define CHECK_IP() \
+ do { if (ip < bp->base || ip - bp->base > bp->len) 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() \
+{ \
+ if (bp != SCM_PROGRAM_DATA (program)) { \
+ bp = SCM_PROGRAM_DATA (program); \
+ if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
+ objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
+ object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
+ } else { \
+ objects = NULL; \
+ object_count = 0; \
+ } \
+ } \
+}
+
+#define SYNC_BEFORE_GC() \
+{ \
+ SYNC_REGISTER (); \
+}
+
+#define SYNC_ALL() \
+{ \
+ SYNC_REGISTER (); \
+}
+
+\f
+/*
+ * Error check
+ */
+
+#undef CHECK_EXTERNAL
+#if VM_CHECK_EXTERNAL
+#define CHECK_EXTERNAL(e) \
+ do { if (SCM_UNLIKELY (!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 (SCM_UNLIKELY ((_num) >= object_count)) goto vm_error_object; } while (0)
+#else
+#define CHECK_OBJECT(_num)
+#endif
+
+\f
+/*
+ * Hooks
+ */
+
+#undef RUN_HOOK
+#if VM_USE_HOOKS
+#define RUN_HOOK(h) \
+{ \
+ if (SCM_UNLIKELY (!SCM_FALSEP (vp->hooks[h])))\
+ { \
+ SYNC_REGISTER (); \
+ vm_dispatch_hook (vp, vp->hooks[h], hook_args); \
+ CACHE_REGISTER (); \
+ } \
+}
+#else
+#define RUN_HOOK(h)
+#endif
+
+#define BOOT_HOOK() RUN_HOOK (SCM_VM_BOOT_HOOK)
+#define HALT_HOOK() RUN_HOOK (SCM_VM_HALT_HOOK)
+#define NEXT_HOOK() RUN_HOOK (SCM_VM_NEXT_HOOK)
+#define BREAK_HOOK() RUN_HOOK (SCM_VM_BREAK_HOOK)
+#define ENTER_HOOK() RUN_HOOK (SCM_VM_ENTER_HOOK)
+#define APPLY_HOOK() RUN_HOOK (SCM_VM_APPLY_HOOK)
+#define EXIT_HOOK() RUN_HOOK (SCM_VM_EXIT_HOOK)
+#define RETURN_HOOK() RUN_HOOK (SCM_VM_RETURN_HOOK)
+
+\f
+/*
+ * Stack operation
+ */
+
+#ifdef VM_ENABLE_STACK_NULLING
+# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
+# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
+# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
+/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
+ inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
+ that continuation doesn't have a chance to run. It's not important on a
+ semantic level, but it does mess up our stack nulling -- so this macro is to
+ fix that. */
+# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
+#else
+# define CHECK_STACK_LEAKN(_n)
+# define CHECK_STACK_LEAK()
+# define NULLSTACK(_n)
+# define NULLSTACK_FOR_NONLOCAL_EXIT()
+#endif
+
+#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 (); NULLSTACK (1); } while (0)
+#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } 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, x; \
+ for (i = n; i; i--) \
+ { \
+ POP (x); \
+ CONS (l, x, l); \
+ } \
+ PUSH (l); \
+} while (0)
+
+/* The opposite: push all of the elements in L onto the list. */
+#define PUSH_LIST(l, NILP) \
+do \
+{ \
+ for (; scm_is_pair (l); l = SCM_CDR (l)) \
+ PUSH (SCM_CAR (l)); \
+ if (SCM_UNLIKELY (!NILP (l))) { \
+ finish_args = scm_list_1 (l); \
+ goto vm_error_improper_list; \
+ } \
+} while (0)
+
+\f
+#define POP_LIST_MARK() \
+do { \
+ SCM o; \
+ SCM l = SCM_EOL; \
+ POP (o); \
+ while (!SCM_UNBNDP (o)) \
+ { \
+ CONS (l, o, l); \
+ POP (o); \
+ } \
+ PUSH (l); \
+} while (0)
+
+#define POP_CONS_MARK() \
+do { \
+ SCM o, l; \
+ POP (l); \
+ POP (o); \
+ while (!SCM_UNBNDP (o)) \
+ { \
+ CONS (l, o, l); \
+ POP (o); \
+ } \
+ PUSH (l); \
+} while (0)
+
+\f
+/*
+ * Instruction operation
+ */
+
+#define FETCH() (*ip++)
+#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } 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 () & SCM_VM_INSTRUCTION_MASK]
+#else
+#define NEXT_JUMP() goto vm_start
+#endif
+
+#define NEXT \
+{ \
+ CLOCK (1); \
+ NEXT_HOOK (); \
+ CHECK_STACK_LEAK (); \
+ NEXT_JUMP (); \
+}
+
+\f
+/*
+ * Stack frame
+ */
+
+#define INIT_ARGS() \
+{ \
+ if (SCM_UNLIKELY (bp->nrest)) \
+ { \
+ int n = nargs - (bp->nargs - 1); \
+ if (n < 0) \
+ goto vm_error_wrong_num_args; \
+ /* NB, can cause GC while setting up the \
+ stack frame */ \
+ POP_LIST (n); \
+ } \
+ else \
+ { \
+ if (SCM_UNLIKELY (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 + 3; \
+ CHECK_OVERFLOW (); \
+ stack_base = sp; \
+ ip = bp->base; \
+ \
+ /* Init local variables */ \
+ for (i=bp->nlocs; i; i--) \
+ data[-i] = SCM_UNDEFINED; \
+ \
+ /* Set frame data */ \
+ data[3] = (SCM)ra; \
+ data[2] = 0x0; \
+ data[1] = (SCM)dl; \
+ \
+ /* Postpone initializing external vars, \
+ because if the CONS causes a GC, we \
+ want the stack marker to see the data \
+ array formatted as expected. */ \
+ data[0] = SCM_UNDEFINED; \
+ external = SCM_PROGRAM_EXTERNALS (fp[-1]); \
+ for (i = 0; i < bp->nexts; i++) \
+ CONS (external, SCM_UNDEFINED, external); \
+ data[0] = external; \
+}
+
+#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef VM_LABEL
+#define VM_LABEL(tag) l_##tag
+#define VM_OPCODE(tag) scm_op_##tag
+
+#ifdef HAVE_LABELS_AS_VALUES
+#define VM_TAG(tag) VM_LABEL(tag):
+#define VM_ADDR(tag) &&VM_LABEL(tag)
+#else /* not HAVE_LABELS_AS_VALUES */
+#define VM_TAG(tag) case VM_OPCODE(tag):
+#define VM_ADDR(tag) NULL
+#endif /* not HAVE_LABELS_AS_VALUES */
+#endif /* VM_LABEL */
+
+#undef VM_DEFINE_FUNCTION
+#undef VM_DEFINE_LOADER
+#define VM_DEFINE_FUNCTION(code,tag,name,nargs) \
+ VM_DEFINE_INSTRUCTION(code,tag,name,0,nargs,1)
+#define VM_DEFINE_LOADER(code,tag,name) \
+ VM_DEFINE_INSTRUCTION(code,tag,name,-1,0,1)
+
+#undef VM_DEFINE_INSTRUCTION
+/*
+ * These will go to scm_instruction_table in instructions.c
+ */
+#ifdef VM_INSTRUCTION_TO_TABLE
+#define VM_DEFINE_INSTRUCTION(code_,tag_,name_,len_,npop_,npush_) \
+ table[VM_OPCODE (tag_)].opcode = VM_OPCODE (tag_); \
+ table[VM_OPCODE (tag_)].name = name_; \
+ table[VM_OPCODE (tag_)].len = len_; \
+ table[VM_OPCODE (tag_)].npop = npop_; \
+ table[VM_OPCODE (tag_)].npush = npush_;
+
+#else
+#ifdef VM_INSTRUCTION_TO_LABEL
+/*
+ * These will go to jump_table in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) jump_table[VM_OPCODE (tag)] = VM_ADDR (tag);
+
+#else
+#ifdef VM_INSTRUCTION_TO_OPCODE
+/*
+ * These will go to scm_opcode in instructions.h
+ */
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) VM_OPCODE (tag) = code,
+
+#else /* Otherwise */
+/*
+ * These are directly included in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) VM_TAG (tag)
+
+#endif /* VM_INSTRUCTION_TO_OPCODE */
+#endif /* VM_INSTRUCTION_TO_LABEL */
+#endif /* VM_INSTRUCTION_TO_TABLE */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+/* This file is included in vm_engine.c */
+
+VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer")
+{
+ size_t len;
+
+ FETCH_LENGTH (len);
+ if (SCM_LIKELY (len <= 4))
+ {
+ unsigned int val = 0;
+ while (len-- > 0)
+ val = (val << 8U) + FETCH ();
+ SYNC_REGISTER ();
+ PUSH (scm_from_uint (val));
+ NEXT;
+ }
+ else
+ SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL);
+}
+
+VM_DEFINE_LOADER (60, load_integer, "load-integer")
+{
+ size_t len;
+
+ FETCH_LENGTH (len);
+ if (SCM_LIKELY (len <= 4))
+ {
+ int val = 0;
+ while (len-- > 0)
+ val = (val << 8) + FETCH ();
+ SYNC_REGISTER ();
+ PUSH (scm_from_int (val));
+ NEXT;
+ }
+ else
+ SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
+}
+
+VM_DEFINE_LOADER (61, 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 (62, 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 (63, 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 (64, 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 (65, load_program, "load-program")
+{
+ scm_t_uint32 len;
+ SCM objs, objcode;
+
+ POP (objs);
+ SYNC_REGISTER ();
+
+ if (scm_is_vector (objs) && scm_is_false (scm_c_vector_ref (objs, 0)))
+ scm_c_vector_set_x (objs, 0, scm_current_module ());
+
+ objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
+ len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
+
+ PUSH (scm_make_program (objcode, objs, SCM_EOL));
+
+ ip += len;
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (66, 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))
+ {
+ finish_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 (67, 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;
+}
+
+/*
+(defun renumber-ops ()
+ "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+ (interactive "")
+ (save-excursion
+ (let ((counter 59)) (goto-char (point-min))
+ (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+ (replace-match
+ (number-to-string (setq counter (1+ counter)))
+ t t nil 1)))))
+*/
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* This file is included in vm_engine.c */
+
+\f
+/*
+ * Predicates
+ */
+
+#define ARGS1(a1) SCM a1 = sp[0];
+#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
+#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);
+
+#define RETURN(x) do { *sp = x; NEXT; } while (0)
+
+VM_DEFINE_FUNCTION (80, not, "not", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (81, not_not, "not-not", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (!SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (82, eq, "eq?", 2)
+{
+ ARGS2 (x, y);
+ RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2)
+{
+ ARGS2 (x, y);
+ RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (84, nullp, "null?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (!SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (86, 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 (87, 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 (88, pairp, "pair?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_CONSP (x)));
+}
+
+VM_DEFINE_FUNCTION (89, listp, "list?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (scm_ilength (x) >= 0));
+}
+
+\f
+/*
+ * Basic data
+ */
+
+VM_DEFINE_FUNCTION (90, cons, "cons", 2)
+{
+ ARGS2 (x, y);
+ CONS (x, x, y);
+ RETURN (x);
+}
+
+#define VM_VALIDATE_CONS(x) \
+ if (SCM_UNLIKELY (!scm_is_pair (x))) \
+ { finish_args = x; \
+ goto vm_error_not_a_pair; \
+ }
+
+VM_DEFINE_FUNCTION (91, car, "car", 1)
+{
+ ARGS1 (x);
+ VM_VALIDATE_CONS (x);
+ RETURN (SCM_CAR (x));
+}
+
+VM_DEFINE_FUNCTION (92, cdr, "cdr", 1)
+{
+ ARGS1 (x);
+ VM_VALIDATE_CONS (x);
+ RETURN (SCM_CDR (x));
+}
+
+VM_DEFINE_FUNCTION (93, set_car, "set-car!", 2)
+{
+ ARGS2 (x, y);
+ VM_VALIDATE_CONS (x);
+ SCM_SETCAR (x, y);
+ RETURN (SCM_UNSPECIFIED);
+}
+
+VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2)
+{
+ ARGS2 (x, y);
+ VM_VALIDATE_CONS (x);
+ SCM_SETCDR (x, y);
+ RETURN (SCM_UNSPECIFIED);
+}
+
+\f
+/*
+ * Numeric relational tests
+ */
+
+#undef REL
+#define REL(crel,srel) \
+{ \
+ ARGS2 (x, y); \
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
+ RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y))); \
+ SYNC_REGISTER (); \
+ RETURN (srel (x, y)); \
+}
+
+VM_DEFINE_FUNCTION (95, ee, "ee?", 2)
+{
+ REL (==, scm_num_eq_p);
+}
+
+VM_DEFINE_FUNCTION (96, lt, "lt?", 2)
+{
+ REL (<, scm_less_p);
+}
+
+VM_DEFINE_FUNCTION (97, le, "le?", 2)
+{
+ REL (<=, scm_leq_p);
+}
+
+VM_DEFINE_FUNCTION (98, gt, "gt?", 2)
+{
+ REL (>, scm_gr_p);
+}
+
+VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
+{
+ REL (>=, scm_geq_p);
+}
+
+\f
+/*
+ * 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 (100, add, "add", 2)
+{
+ FUNC2 (+, scm_sum);
+}
+
+VM_DEFINE_FUNCTION (101, sub, "sub", 2)
+{
+ FUNC2 (-, scm_difference);
+}
+
+VM_DEFINE_FUNCTION (102, mul, "mul", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_product (x, y));
+}
+
+VM_DEFINE_FUNCTION (103, div, "div", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_divide (x, y));
+}
+
+VM_DEFINE_FUNCTION (104, quo, "quo", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_quotient (x, y));
+}
+
+VM_DEFINE_FUNCTION (105, rem, "rem", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_remainder (x, y));
+}
+
+VM_DEFINE_FUNCTION (106, mod, "mod", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_modulo (x, y));
+}
+
+\f
+/*
+ * GOOPS support
+ */
+VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
+{
+ size_t slot;
+ ARGS2 (instance, idx);
+ slot = SCM_I_INUM (idx);
+ RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
+}
+
+VM_DEFINE_FUNCTION (108, slot_set, "slot-set", 3)
+{
+ size_t slot;
+ ARGS3 (instance, idx, val);
+ slot = SCM_I_INUM (idx);
+ SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
+ RETURN (SCM_UNSPECIFIED);
+}
+
+/*
+(defun renumber-ops ()
+ "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+ (interactive "")
+ (save-excursion
+ (let ((counter 79)) (goto-char (point-min))
+ (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+ (replace-match
+ (number-to-string (setq counter (1+ counter)))
+ t t nil 1)))))
+*/
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+/* This file is included in vm_engine.c */
+
+\f
+/*
+ * Basic operations
+ */
+
+VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
+{
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
+{
+ vp->time += scm_c_get_internal_run_time () - start_time;
+ HALT_HOOK ();
+ nvalues = SCM_I_INUM (*sp--);
+ NULLSTACK (1);
+ if (nvalues == 1)
+ POP (finish_args);
+ else
+ {
+ POP_LIST (nvalues);
+ POP (finish_args);
+ SYNC_REGISTER ();
+ finish_args = scm_values (finish_args);
+ }
+
+ {
+ ASSERT (sp == stack_base);
+ ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+
+ /* Restore registers */
+ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
+ ip = NULL;
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
+ NULLSTACK (stack_base - sp);
+ }
+
+ goto vm_done;
+}
+
+VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
+{
+ BREAK_HOOK ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
+{
+ DROP ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (4, mark, "mark", 0, 0, 1)
+{
+ PUSH (SCM_UNDEFINED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
+{
+ SCM x = *sp;
+ PUSH (x);
+ NEXT;
+}
+
+\f
+/*
+ * Object creation
+ */
+
+VM_DEFINE_INSTRUCTION (6, void, "void", 0, 0, 1)
+{
+ PUSH (SCM_UNSPECIFIED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (7, make_true, "make-true", 0, 0, 1)
+{
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (8, make_false, "make-false", 0, 0, 1)
+{
+ PUSH (SCM_BOOL_F);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1)
+{
+ PUSH (SCM_EOL);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1)
+{
+ PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1)
+{
+ PUSH (SCM_INUM0);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1)
+{
+ PUSH (SCM_I_MAKINUM (1));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (13, 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 (14, make_char8, "make-char8", 1, 0, 1)
+{
+ PUSH (SCM_MAKE_CHAR (FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ unsigned len = ((h << 8) + l);
+ POP_LIST (len);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ unsigned len = ((h << 8) + l);
+ SCM vect;
+
+ SYNC_REGISTER ();
+ sp++; sp -= len;
+ CHECK_UNDERFLOW ();
+ vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F);
+ memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len);
+ NULLSTACK (len);
+ *sp = vect;
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (17, list_mark, "list-mark", 0, 0, 0)
+{
+ POP_LIST_MARK ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (18, cons_mark, "cons-mark", 0, 0, 0)
+{
+ POP_CONS_MARK ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0)
+{
+ POP_LIST_MARK ();
+ SYNC_REGISTER ();
+ *sp = scm_vector (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0)
+{
+ SCM l;
+ POP (l);
+ PUSH_LIST (l, SCM_NULLP);
+ NEXT;
+}
+
+\f
+/*
+ * Variable access
+ */
+
+#define OBJECT_REF(i) objects[i]
+#define OBJECT_SET(i,o) objects[i] = o
+
+#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
+#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
+
+/* For the variable operations, we _must_ obviously avoid function calls to
+ `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
+ nothing more than the corresponding macros. */
+#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
+#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
+#define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED)
+
+/* ref */
+
+VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
+{
+ register unsigned objnum = FETCH ();
+ CHECK_OBJECT (objnum);
+ PUSH (OBJECT_REF (objnum));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
+{
+ PUSH (LOCAL_REF (FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (23, 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 (24, variable_ref, "variable-ref", 0, 0, 1)
+{
+ SCM x = *sp;
+
+ if (!VARIABLE_BOUNDP (x))
+ {
+ finish_args = SCM_LIST1 (x);
+ /* Was: finish_args = SCM_LIST1 (SCM_CAR (x)); */
+ goto vm_error_unbound;
+ }
+ else
+ {
+ SCM o = VARIABLE_REF (x);
+ *sp = o;
+ }
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-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)))
+ {
+ SCM mod = SCM_EOL;
+ if (SCM_LIKELY (scm_module_system_booted_p
+ && scm_is_true ((mod = scm_program_module (program)))))
+ /* might longjmp */
+ what = scm_module_lookup (mod, 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))
+ {
+ finish_args = SCM_LIST1 (mod);
+ goto vm_error_no_such_module;
+ }
+ /* might longjmp */
+ what = scm_module_lookup (mod, SCM_CADR (what));
+ }
+
+ if (!VARIABLE_BOUNDP (what))
+ {
+ finish_args = SCM_LIST1 (what);
+ goto vm_error_unbound;
+ }
+
+ OBJECT_SET (objnum, what);
+ }
+
+ PUSH (VARIABLE_REF (what));
+ NEXT;
+}
+
+/* set */
+
+VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
+{
+ LOCAL_SET (FETCH (), *sp);
+ DROP ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (27, 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 (28, variable_set, "variable-set", 0, 1, 0)
+{
+ VARIABLE_SET (sp[0], sp[-1]);
+ DROPN (2);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-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)))
+ {
+ SCM mod = SCM_EOL;
+ if (SCM_LIKELY (scm_module_system_booted_p
+ && scm_is_true ((mod = scm_program_module (program)))))
+ /* might longjmp */
+ what = scm_module_lookup (mod, 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))
+ {
+ finish_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;
+}
+
+VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
+{
+ PUSH (external);
+ NEXT;
+}
+
+\f
+/*
+ * 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; \
+ NULLSTACK (1); \
+ DROP (); \
+ NEXT; \
+}
+
+VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
+{
+ int h = FETCH ();
+ int l = FETCH ();
+ ip += (signed short) (h << 8) + l;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
+{
+ BR (!SCM_FALSEP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
+{
+ BR (SCM_FALSEP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
+{
+ BR (SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+{
+ BR (!SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
+{
+ BR (SCM_NULLP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
+{
+ BR (!SCM_NULLP (*sp));
+}
+
+\f
+/*
+ * Subprogram call
+ */
+
+VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1)
+{
+ SYNC_BEFORE_GC ();
+ SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
+ SCM_PROGRAM_OBJTABLE (*sp), external);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
+{
+ SCM x;
+ nargs = FETCH ();
+
+ vm_call:
+ x = sp[-nargs];
+
+ SYNC_REGISTER ();
+ SCM_TICK; /* allow interrupt here */
+
+ /*
+ * 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. */
+ POP_LIST (nargs);
+ SYNC_REGISTER ();
+ /* keep args on stack so they are marked */
+ sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ NULLSTACK_FOR_NONLOCAL_EXIT ();
+ DROP ();
+ if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
+ {
+ /* truncate values */
+ SCM values;
+ POP (values);
+ values = scm_struct_ref (values, SCM_INUM0);
+ if (scm_is_null (values))
+ goto vm_error_not_enough_values;
+ PUSH (SCM_CAR (values));
+ }
+ 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 (40, goto_args, "goto/args", 1, -1, 1)
+{
+ register SCM x;
+ nargs = FETCH ();
+ vm_goto_args:
+ x = sp[-nargs];
+
+ SYNC_REGISTER ();
+ 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;
+ NULLSTACK (bp->nargs + 1);
+
+ /* Freshen the externals */
+ external = SCM_PROGRAM_EXTERNALS (x);
+ for (i = 0; i < bp->nexts; i++)
+ CONS (external, SCM_UNDEFINED, external);
+ SCM_FRAME_DATA_ADDRESS (fp)[0] = external;
+
+ /* Init locals to valid SCM values */
+ for (i = 0; i < bp->nlocs; i++)
+ LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
+
+ /* 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;
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp;
+#endif
+
+ 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 */
+ program = x;
+ CACHE_PROGRAM ();
+ INIT_ARGS ();
+ /* delay updating the frame so that if INIT_ARGS has to cons up a rest
+ arg, going into GC, the stack still makes sense */
+ fp[-1] = program;
+ nargs = bp->nargs;
+
+#ifdef VM_ENABLE_STACK_NULLING
+ old_sp = sp;
+ CHECK_STACK_LEAK ();
+#endif
+
+ /* 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 + 3;
+ sp = stack_base;
+ CHECK_OVERFLOW ();
+
+ /* copy args, bottom-up */
+ for (i = 0; i < nargs; i++)
+ fp[i] = tail_args[i];
+
+ NULLSTACK (old_sp - sp);
+
+ /* init locals */
+ for (i = bp->nlocs; i; i--)
+ data[-i] = SCM_UNDEFINED;
+
+ /* Set frame data */
+ data[3] = (SCM)ra;
+ data[2] = (SCM)mvra;
+ data[1] = (SCM)dl;
+
+ /* Postpone initializing external vars, because if the CONS causes a GC,
+ we want the stack marker to see the data array formatted as expected. */
+ data[0] = SCM_UNDEFINED;
+ external = SCM_PROGRAM_EXTERNALS (fp[-1]);
+ for (i = 0; i < bp->nexts; i++)
+ CONS (external, SCM_UNDEFINED, external);
+ 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)))
+ {
+ POP_LIST (nargs);
+ SYNC_REGISTER ();
+ sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ NULLSTACK_FOR_NONLOCAL_EXIT ();
+ DROP ();
+ if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
+ {
+ /* multiple values returned to continuation */
+ SCM values;
+ POP (values);
+ values = scm_struct_ref (values, SCM_INUM0);
+ nvalues = scm_ilength (values);
+ PUSH_LIST (values, SCM_NULLP);
+ goto vm_return_values;
+ }
+ 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 (41, 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 (42, 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 (43, 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)[2] = (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. */
+ POP_LIST (nargs);
+ SYNC_REGISTER ();
+ sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ NULLSTACK_FOR_NONLOCAL_EXIT ();
+ DROP ();
+ if (SCM_VALUESP (*sp))
+ {
+ SCM values, len;
+ POP (values);
+ values = scm_struct_ref (values, SCM_INUM0);
+ len = scm_length (values);
+ PUSH_LIST (values, SCM_NULLP);
+ 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 (44, apply, "apply", 1, -1, 1)
+{
+ int len;
+ SCM ls;
+ POP (ls);
+
+ nargs = FETCH ();
+ ASSERT (nargs >= 2);
+
+ len = scm_ilength (ls);
+ if (len < 0)
+ goto vm_error_wrong_type_arg;
+
+ PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
+
+ nargs += len - 2;
+ goto vm_call;
+}
+
+VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
+{
+ int len;
+ SCM ls;
+ POP (ls);
+
+ nargs = FETCH ();
+ ASSERT (nargs >= 2);
+
+ len = scm_ilength (ls);
+ if (len < 0)
+ goto vm_error_wrong_type_arg;
+
+ PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
+
+ nargs += len - 2;
+ goto vm_goto_args;
+}
+
+VM_DEFINE_INSTRUCTION (46, 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;
+ }
+ ASSERT (sp == vp->sp);
+ ASSERT (fp == vp->fp);
+ 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_no_values;
+ /* non-tail context does not accept multiple values? */
+ PUSH (SCM_CAR (values));
+ NEXT;
+ }
+ else
+ {
+ PUSH (cont);
+ NEXT;
+ }
+}
+
+VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
+{
+ int first;
+ SCM proc, cont;
+ POP (proc);
+ SYNC_ALL ();
+ cont = scm_make_continuation (&first);
+ ASSERT (sp == vp->sp);
+ ASSERT (fp == vp->fp);
+ 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);
+ PUSH_LIST (values, SCM_NULLP);
+ goto vm_return_values;
+ }
+ else
+ {
+ PUSH (cont);
+ goto vm_return;
+ }
+}
+
+VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
+{
+ vm_return:
+ EXIT_HOOK ();
+ RETURN_HOOK ();
+ SYNC_REGISTER ();
+ SCM_TICK; /* allow interrupt here */
+ {
+ SCM ret, *data;
+ data = SCM_FRAME_DATA_ADDRESS (fp);
+
+ POP (ret);
+ ASSERT (sp == stack_base);
+ ASSERT (stack_base == data + 3);
+
+ /* Restore registers */
+ sp = SCM_FRAME_LOWER_ADDRESS (fp);
+ ip = SCM_FRAME_BYTE_CAST (data[3]);
+ fp = SCM_FRAME_STACK_CAST (data[1]);
+ {
+#ifdef VM_ENABLE_STACK_NULLING
+ int nullcount = stack_base - sp;
+#endif
+ stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ NULLSTACK (nullcount);
+ }
+
+ /* 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 (49, 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);
+ ASSERT (stack_base == data + 3);
+
+ /* data[2] is the mv return address */
+ if (nvalues != 1 && data[2])
+ {
+ int i;
+ /* Restore registers */
+ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
+ ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */
+ fp = SCM_FRAME_STACK_CAST (data[1]);
+
+ /* 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 */
+ NULLSTACK (stack_base - sp + nvalues + 1);
+ 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[3]); /* single value ra */
+ fp = SCM_FRAME_STACK_CAST (data[1]);
+
+ /* Push first value */
+ *++sp = stack_base[1];
+
+ /* Finally set new stack_base */
+ NULLSTACK (stack_base - sp + nvalues + 1);
+ 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 (50, return_values_star, "return/values*", 1, -1, -1)
+{
+ SCM l;
+
+ nvalues = FETCH ();
+ ASSERT (nvalues >= 1);
+
+ nvalues--;
+ POP (l);
+ while (SCM_CONSP (l))
+ {
+ PUSH (SCM_CAR (l));
+ l = SCM_CDR (l);
+ nvalues++;
+ }
+ if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
+ finish_args = scm_list_1 (l);
+ goto vm_error_improper_list;
+ }
+
+ goto vm_return_values;
+}
+
+VM_DEFINE_INSTRUCTION (51, 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;
+}
+
+/*
+(defun renumber-ops ()
+ "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+ (interactive "")
+ (save-excursion
+ (let ((counter -1)) (goto-char (point-min))
+ (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+ (replace-match
+ (number-to-string (setq counter (1+ counter)))
+ t t nil 1)))))
+*/
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "frames.h"
+#include "instructions.h"
+#include "objcodes.h"
+#include "programs.h"
+#include "lang.h" /* NULL_OR_NIL_P */
+#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 ()); \
+}
+
+/* The VM has a number of internal assertions that shouldn't normally be
+ necessary, but might be if you think you found a bug in the VM. */
+#define VM_ENABLE_ASSERTIONS
+
+/* We can add a mode that ensures that all stack items above the stack pointer
+ are NULL. This is useful for checking the internal consistency of the VM's
+ assumptions and its operators, but isn't necessary for normal operation. It
+ will ensure that assertions are enabled. Slows down the VM by about 30%. */
+/* NB! If you enable this, search for NULLING in throw.c */
+/* #define VM_ENABLE_STACK_NULLING */
+
+/* #define VM_ENABLE_PARANOID_ASSERTIONS */
+
+#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
+#define VM_ENABLE_ASSERTIONS
+#endif
+
+\f
+/*
+ * VM Continuation
+ */
+
+scm_t_bits scm_tc16_vm_cont;
+
+static void
+vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
+{
+ SCM *sp, *upper, *lower;
+ sp = base + size - 1;
+
+ while (sp > base && fp)
+ {
+ upper = SCM_FRAME_UPPER_ADDRESS (fp);
+ lower = SCM_FRAME_LOWER_ADDRESS (fp);
+
+ for (; sp >= upper; sp--)
+ if (SCM_NIMP (*sp))
+ {
+ if (scm_in_heap_p (*sp))
+ scm_gc_mark (*sp);
+ else
+ fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp);
+ }
+
+
+ /* skip ra, mvra */
+ sp -= 2;
+
+ /* update fp from the dynamic link */
+ fp = (SCM*)*sp-- + reloc;
+
+ /* mark from the el down to the lower address */
+ for (; sp >= lower; sp--)
+ if (*sp && SCM_NIMP (*sp))
+ scm_gc_mark (*sp);
+ }
+}
+
+static SCM
+vm_cont_mark (SCM obj)
+{
+ struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
+
+ if (p->stack_size)
+ vm_mark_stack (p->stack_base, p->stack_size, p->fp + p->reloc, p->reloc);
+
+ 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");
+#ifdef VM_ENABLE_STACK_NULLING
+ if (vp->sp >= vp->stack_base)
+ if (!vp->sp[0] || vp->sp[1])
+ abort ();
+ memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
+#endif
+ p->ip = vp->ip;
+ p->sp = vp->sp;
+ p->fp = vp->fp;
+ memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
+ p->reloc = p->stack_base - vp->stack_base;
+ 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 ();
+ }
+#ifdef VM_ENABLE_STACK_NULLING
+ {
+ scm_t_ptrdiff nzero = (vp->sp - p->sp);
+ if (nzero > 0)
+ memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
+ /* actually nzero should always be negative, because vm_reset_stack will
+ unwind the stack to some point *below* this continuation */
+ }
+#endif
+ vp->ip = p->ip;
+ vp->sp = p->sp;
+ vp->fp = 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));
+}
+
+static void enfalsen_frame (void *p)
+{
+ struct scm_vm *vp = p;
+ vp->trace_frame = SCM_BOOL_F;
+}
+
+static void
+vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
+{
+ if (!SCM_FALSEP (vp->trace_frame))
+ return;
+
+ scm_dynwind_begin (0);
+ // FIXME, stack holder should be the vm
+ vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
+ scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
+
+ scm_c_run_hook (hook, hook_args);
+
+ scm_dynwind_end ();
+}
+
+\f
+/*
+ * VM Internal functions
+ */
+
+static SCM sym_vm_run;
+static SCM sym_vm_error;
+static SCM sym_debug;
+
+static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len)
+{
+ scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector");
+ memcpy (new_bytes, bytes, len);
+ return scm_take_u8vector (new_bytes, len);
+}
+
+static SCM
+really_make_boot_program (long nargs)
+{
+ scm_byte_t bytes[] = {0, 0, 0, 0,
+ 0, 0, 0, 0,
+ 0, 0, 0, 0,
+ scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
+ SCM ret;
+ ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness, no meta */
+ if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
+ abort ();
+ bytes[13] = (scm_byte_t)nargs;
+ ret = scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))),
+ SCM_BOOL_F, SCM_EOL);
+ SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
+ return ret;
+}
+#define NUM_BOOT_PROGS 8
+static SCM
+vm_make_boot_program (long nargs)
+{
+ static SCM programs[NUM_BOOT_PROGS] = { 0, };
+
+ if (SCM_UNLIKELY (!programs[0]))
+ {
+ int i;
+ for (i = 0; i < NUM_BOOT_PROGS; i++)
+ programs[i] = scm_permanent_object (really_make_boot_program (i));
+ }
+
+ if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
+ return programs[nargs];
+ else
+ return really_make_boot_program (nargs);
+}
+
+\f
+/*
+ * VM
+ */
+
+#define VM_DEFAULT_STACK_SIZE (16 * 1024)
+
+#define VM_NAME vm_regular_engine
+#define FUNC_NAME "vm-regular-engine"
+#define VM_ENGINE SCM_VM_REGULAR_ENGINE
+#include "vm-engine.c"
+#undef VM_NAME
+#undef FUNC_NAME
+#undef VM_ENGINE
+
+#define VM_NAME vm_debug_engine
+#define FUNC_NAME "vm-debug-engine"
+#define VM_ENGINE SCM_VM_DEBUG_ENGINE
+#include "vm-engine.c"
+#undef VM_NAME
+#undef FUNC_NAME
+#undef VM_ENGINE
+
+static const scm_t_vm_engine vm_engines[] =
+ { vm_regular_engine, vm_debug_engine };
+
+scm_t_bits scm_tc16_vm;
+
+static SCM
+make_vm (void)
+#define FUNC_NAME "make_vm"
+{
+ int i;
+
+ if (!scm_tc16_vm)
+ return SCM_BOOL_F; /* not booted yet */
+
+ 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");
+#ifdef VM_ENABLE_STACK_NULLING
+ memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
+#endif
+ vp->stack_limit = vp->stack_base + vp->stack_size - 3;
+ vp->ip = NULL;
+ vp->sp = vp->stack_base - 1;
+ vp->fp = NULL;
+ vp->engine = SCM_VM_DEBUG_ENGINE;
+ vp->time = 0;
+ vp->clock = 0;
+ vp->options = SCM_EOL;
+ for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+ vp->hooks[i] = SCM_BOOL_F;
+ vp->trace_frame = 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);
+
+#ifdef VM_ENABLE_STACK_NULLING
+ if (vp->sp >= vp->stack_base)
+ if (!vp->sp[0] || vp->sp[1])
+ abort ();
+#endif
+
+ /* mark the stack, precisely */
+ vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
+
+ /* mark other objects */
+ for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+ scm_gc_mark (vp->hooks[i]);
+
+ scm_gc_mark (vp->trace_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_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
+{
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+ return vm_engines[vp->engine](vp, program, argv, nargs);
+}
+
+SCM
+scm_vm_apply (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "scm_vm_apply"
+{
+ SCM *argv;
+ int i, nargs;
+
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VALIDATE_PROGRAM (2, program);
+
+ nargs = scm_ilength (args);
+ if (SCM_UNLIKELY (nargs < 0))
+ scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
+
+ argv = alloca(nargs * sizeof(SCM));
+ for (i = 0; i < nargs; i++)
+ {
+ argv[i] = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+
+ return scm_c_vm_run (vm, program, argv, nargs);
+}
+#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_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ if (SCM_UNLIKELY (SCM_FALSEP ((t->vm))))
+ t->vm = make_vm ();
+
+ return t->vm;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_vm_p
+{
+ return SCM_BOOL (SCM_VM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_make_vm,
+{
+ return make_vm ();
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_ip
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_sp
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fp
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
+}
+#undef FUNC_NAME
+
+#define VM_DEFINE_HOOK(n) \
+{ \
+ struct scm_vm *vp; \
+ SCM_VALIDATE_VM (1, vm); \
+ vp = SCM_VM_DATA (vm); \
+ if (SCM_FALSEP (vp->hooks[n])) \
+ vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
+ return vp->hooks[n]; \
+}
+
+SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_boot_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_halt_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_next_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_break_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_enter_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_apply_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_exit_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_return_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
+ (SCM vm, SCM key),
+ "")
+#define FUNC_NAME s_scm_vm_option
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
+ (SCM vm, SCM key, SCM val),
+ "")
+#define FUNC_NAME s_scm_set_vm_option_x
+{
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VM_DATA (vm)->options
+ = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_stats
+{
+ SCM stats;
+
+ SCM_VALIDATE_VM (1, vm);
+
+ stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
+ scm_vector_set_x (stats, SCM_I_MAKINUM (0),
+ scm_from_ulong (SCM_VM_DATA (vm)->time));
+ scm_vector_set_x (stats, SCM_I_MAKINUM (1),
+ scm_from_ulong (SCM_VM_DATA (vm)->clock));
+
+ return stats;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_trace_frame
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->trace_frame;
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * Initialize
+ */
+
+SCM scm_load_compiled_with_vm (SCM file)
+{
+ SCM program = scm_make_program (scm_load_objcode (file),
+ SCM_BOOL_F, SCM_EOL);
+
+ return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
+}
+
+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_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:
+*/
--- /dev/null
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _SCM_VM_H_
+#define _SCM_VM_H_
+
+#include <libguile.h>
+#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;
+
+typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM program, SCM *argv, int nargs);
+
+#define SCM_VM_REGULAR_ENGINE 0
+#define SCM_VM_DEBUG_ENGINE 1
+#define SCM_VM_NUM_ENGINES 2
+
+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 */
+ int engine; /* which vm engine we're using */
+ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
+ SCM options; /* options */
+ unsigned long time; /* time spent */
+ unsigned long clock; /* bogos clock */
+ SCM trace_frame; /* a frame being traced */
+};
+
+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_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+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_trace_frame (SCM vm);
+
+struct scm_vm_cont {
+ scm_byte_t *ip;
+ SCM *sp;
+ SCM *fp;
+ scm_t_ptrdiff stack_size;
+ SCM *stack_base;
+ scm_t_ptrdiff reloc;
+};
+
+extern scm_t_bits scm_tc16_vm_cont;
+#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
+#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
+
+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:
+*/
--- /dev/null
+dnl check for gcc's "labels as values" feature
+AC_DEFUN([AC_C_LABELS_AS_VALUES],
+[AC_CACHE_CHECK([labels as values], ac_cv_labels_as_values,
+[AC_TRY_COMPILE([
+int foo(int);
+int foo(i)
+int i; {
+static void *label[] = { &&l1, &&l2 };
+goto *label[i];
+l1: return 1;
+l2: return 2;
+}
+],
+[int i;],
+ac_cv_labels_as_values=yes,
+ac_cv_labels_as_values=no)])
+if test "$ac_cv_labels_as_values" = yes; then
+AC_DEFINE([HAVE_LABELS_AS_VALUES], [],
+ [Define if compiler supports gcc's "labels as values" (aka computed goto)
+ feature, used to speed up instruction dispatch in the interpreter.])
+fi
+])
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2009 Free Software Foundation, Inc.
+##
+## This file is part of GUILE.
+##
+## GUILE 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.
+##
+## GUILE 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 GUILE; see the file COPYING. If not, write
+## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+## Floor, Boston, MA 02110-1301 USA
+
+# Build the compiler and VM support first to avoid stack overflows
+# when building the rest.
+SUBDIRS = . ice-9 srfi oop
+
+# We're at the root of the module hierarchy.
+modpath =
+
+SOURCES = \
+ system/base/pmatch.scm system/base/syntax.scm \
+ system/base/compile.scm system/base/language.scm \
+ \
+ system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
+ system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
+ system/vm/trace.scm system/vm/vm.scm \
+ \
+ system/repl/repl.scm system/repl/common.scm \
+ system/repl/command.scm \
+ \
+ language/ghil.scm language/glil.scm language/assembly.scm \
+ \
+ $(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \
+ $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
+ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
+ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)
+
+SCHEME_LANG_SOURCES = \
+ language/scheme/amatch.scm language/scheme/expand.scm \
+ language/scheme/compile-ghil.scm language/scheme/spec.scm \
+ language/scheme/inline.scm
+
+GHIL_LANG_SOURCES = \
+ language/ghil/spec.scm language/ghil/compile-glil.scm
+
+GLIL_LANG_SOURCES = \
+ language/glil/spec.scm language/glil/compile-assembly.scm
+
+ASSEMBLY_LANG_SOURCES = \
+ language/assembly/spec.scm \
+ language/assembly/compile-bytecode.scm \
+ language/assembly/decompile-bytecode.scm \
+ language/assembly/disassemble.scm
+
+BYTECODE_LANG_SOURCES = \
+ language/bytecode/spec.scm
+
+OBJCODE_LANG_SOURCES = \
+ language/objcode/spec.scm
+
+VALUE_LANG_SOURCES = \
+ language/value/spec.scm
+
+ECMASCRIPT_LANG_SOURCES = \
+ language/ecmascript/parse-lalr.scm \
+ language/ecmascript/tokenize.scm \
+ language/ecmascript/parse.scm \
+ language/ecmascript/spec.scm \
+ language/ecmascript/impl.scm \
+ language/ecmascript/base.scm \
+ language/ecmascript/function.scm \
+ language/ecmascript/array.scm \
+ language/ecmascript/compile-ghil.scm
+
+NOCOMP_SOURCES = \
+ system/repl/describe.scm
+
+include $(top_srcdir)/am/guilec
SUBDIRS = debugger debugging
# These should be installed and distributed.
-ice9_sources = \
- and-let-star.scm boot-9.scm calling.scm common-list.scm \
+modpath = ice-9
+# 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 annotate.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 \
+ lineio.scm ls.scm mapping.scm match.scm \
+ networking.scm null.scm occam-channel.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)
+# gds-client is tight with the memoizer, so punt on it until it can be
+# made portable.
+#
+# psyntax.scm needs help. fortunately it's only needed when recompiling
+# psyntax-pp.scm.
+NOCOMP_SOURCES = gds-client.scm psyntax.scm
+
+include $(top_srcdir)/am/guilec
## 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
--- /dev/null
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+\f
+
+(define-module (ice-9 annotate)
+ :export (<annotation> annotation? annotate deannotate make-annotation
+ annotation-expression annotation-source annotation-stripped
+ set-annotation-stripped!
+ deannotate/source-properties))
+
+(define <annotation>
+ (make-vtable "prprpw"
+ (lambda (struct port)
+ (display "#<annotated " port)
+ (display (struct-ref struct 0) port)
+ (display ">" port))))
+
+(define (annotation? x)
+ (and (struct? x) (eq? (struct-vtable x) <annotation>)))
+
+(define (make-annotation e s . stripped?)
+ (if (null? stripped?)
+ (make-struct <annotation> 0 e s #f)
+ (apply make-struct <annotation> 0 e s stripped?)))
+
+(define (annotation-expression a)
+ (struct-ref a 0))
+(define (annotation-source a)
+ (struct-ref a 1))
+(define (annotation-stripped a)
+ (struct-ref a 2))
+(define (set-annotation-stripped! a stripped?)
+ (struct-set! a 2 stripped?))
+
+(define (annotate e)
+ (let ((p (if (pair? e) (source-properties e) #f))
+ (out (cond ((and (list? e) (not (null? e)))
+ (map annotate e))
+ ((pair? e)
+ (cons (annotate (car e)) (annotate (cdr e))))
+ (else e))))
+ (if (pair? p)
+ (make-annotation out p #f)
+ out)))
+
+(define (deannotate e)
+ (cond ((list? e)
+ (map deannotate e))
+ ((pair? e)
+ (cons (deannotate (car e)) (deannotate (cdr e))))
+ ((annotation? e) (deannotate (annotation-expression e)))
+ (else e)))
+
+(define (deannotate/source-properties e)
+ (cond ((list? e)
+ (map deannotate/source-properties e))
+ ((pair? e)
+ (cons (deannotate/source-properties (car e))
+ (deannotate/source-properties (cdr e))))
+ ((annotation? e)
+ (let ((e (deannotate/source-properties (annotation-expression e)))
+ (source (annotation-source e)))
+ (if (pair? e)
+ (set-source-properties! e source))
+ e))
+ (else e)))
;;; installed-scm-file
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2009
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
\f
-;;; {EVAL-CASE}
-;;;
-
-;; (eval-case ((situation*) forms)* (else forms)?)
+;; (eval-when (situation...) form...)
+;;
+;; Evaluate certain code based on the situation that eval-when is used
+;; in. There are three situations defined.
+;;
+;; `load' triggers when a file is loaded via `load', or when a compiled
+;; file is loaded.
+;;
+;; `compile' triggers when an expression is compiled.
;;
-;; 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.
+;; `eval' triggers when code is evaluated interactively, as at the REPL
+;; or via the `compile' or `eval' procedures.
-(define eval-case
+;; NB: this macro is only ever expanded by the interpreter. The compiler
+;; notices it and interprets the situations differently.
+(define eval-when
(procedure->memoizing-macro
(lambda (exp env)
- (define (toplevel-env? env)
- (or (not (pair? env)) (not (pair? (car env)))))
- (define (syntax)
- (error "syntax error in eval-case"))
- (let loop ((clauses (cdr exp)))
- (cond
- ((null? clauses)
- #f)
- ((not (list? (car clauses)))
- (syntax))
- ((eq? 'else (caar clauses))
- (or (null? (cdr clauses))
- (syntax))
- (cons 'begin (cdar clauses)))
- ((not (list? (caar clauses)))
- (syntax))
- ((and (toplevel-env? env)
- (memq 'load-toplevel (caar clauses)))
- (cons 'begin (cdar clauses)))
- (else
- (loop (cdr clauses))))))))
+ (let ((situations (cadr exp))
+ (body (cddr exp)))
+ (if (or (memq 'load situations)
+ (memq 'eval situations))
+ `(begin . ,body))))))
\f
+;; 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-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
;;; {Defmacros}
;;;
;;; Depends on: features, eval-case
(let ((defmacro-transformer
(lambda (name parms . body)
(let ((transformer `(lambda ,parms ,@body)))
- `(eval-case
- ((load-toplevel)
- (define ,name (defmacro:transformer ,transformer)))
- (else
- (error "defmacro can only be used at the top level")))))))
+ `(eval-when
+ (eval load compile)
+ (define ,name (defmacro:transformer ,transformer)))))))
(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?
(defmacro begin-deprecated forms
(if (include-deprecated-features)
- (cons begin forms)
- #f))
+ `(begin ,@forms)
+ (begin)))
\f
;;; {R4RS compliance}
;;;
-(primitive-load-path "ice-9/r4rs.scm")
+(primitive-load-path "ice-9/r4rs")
\f
\f
-;;; {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))))
-
-\f
-
;;; {Records}
;;;
(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)))))
#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))))
\f
(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
#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)
\f
+;;; {The interpreter stack}
+;;;
+
+(defmacro start-stack (tag exp)
+ `(%start-stack ,tag (lambda () ,exp)))
+
+\f
+
;;; {Loading by paths}
;;;
*unspecified*)
(define module-defer-observers #f)
-(define module-defer-observers-mutex (make-mutex))
+(define module-defer-observers-mutex (make-mutex 'recursive))
(define module-defer-observers-table (make-hash-table))
(define (module-modified m)
;;; 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)
(set-module-name! the-root-module '(guile))
(set-module-name! the-scm-module '(guile))
(set-module-kind! the-scm-module 'interface)
-(for-each set-system-module! (list the-root-module the-scm-module) '(#t #t))
+(set-system-module! the-root-module #t)
+(set-system-module! the-scm-module #t)
;; NOTE: This binding is used in libguile/modules.c.
;;
(define (make-modules-in module name)
(if (null? name)
module
- (cond
- ((module-ref module (car name) #f)
- => (lambda (m) (make-modules-in m (cdr name))))
- (else (let ((m (make-module 31)))
- (set-module-kind! m 'directory)
- (set-module-name! m (append (or (module-name module)
- '())
- (list (car name))))
- (module-define! module (car name) m)
- (make-modules-in m (cdr name)))))))
+ (make-modules-in
+ (let* ((var (module-local-variable module (car name)))
+ (val (and var (variable-bound? var) (variable-ref var))))
+ (if (module? val)
+ val
+ (let ((m (make-module 31)))
+ (set-module-kind! m 'directory)
+ (set-module-name! m (append (or (module-name module) '())
+ (list (car name))))
+ (module-define! module (car name) m)
+ m)))
+ (cdr name))))
(define (beautify-user-module! module)
(let ((interface (module-public-interface module)))
;; 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))
+ (autoload (or (null? maybe-autoload) (car maybe-autoload))))
+ (cond
+ ((and already (module? already)
+ (or (not autoload) (module-public-interface already)))
+ ;; A hit, a palpable hit.
+ already)
+ (autoload
+ ;; Try to autoload the module, and recurse.
+ (try-load-module name)
+ (resolve-module name #f))
+ (else
+ ;; A module is not bound (but maybe something else is),
+ ;; we're not autoloading -- here's the weird semantics,
+ ;; we create an empty module.
+ (make-modules-in the-root-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.
(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)
(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))
;;; {Compiled module}
-(define load-compiled #f)
+(if (not (defined? 'load-compiled))
+ (define load-compiled #f))
\f
(lambda () (autoload-in-progress! dir-hint name))
(lambda ()
(let ((file (in-vicinity dir-hint name)))
- (cond ((and load-compiled
- (%search-load-path (string-append file ".go")))
- => (lambda (full)
- (load-file load-compiled full)))
- ((%search-load-path file)
- => (lambda (full)
- (with-fluids ((current-reader #f))
- (load-file primitive-load full)))))))
+ (let ((compiled (and load-compiled
+ (%search-load-path
+ (string-append file ".go"))))
+ (source (%search-load-path file)))
+ (cond ((and source
+ (or (not compiled)
+ (< (stat:mtime (stat compiled))
+ (stat:mtime (stat source)))))
+ (if compiled
+ (warn "source file" source "newer than" compiled))
+ (with-fluids ((current-reader #f))
+ (load-file primitive-load source)))
+ (compiled
+ (load-file load-compiled compiled))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
;;; {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)
(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
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
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
-(define (default-lazy-handler key . args)
- (save-stack lazy-handler-dispatch)
+(define (default-pre-unwind-handler key . args)
+ (save-stack pre-unwind-handler-dispatch)
(apply throw key args))
-(define (lazy-handler-dispatch key . args)
- (apply default-lazy-handler key args))
+(define (pre-unwind-handler-dispatch key . args)
+ (apply default-pre-unwind-handler key args))
(define abort-hook (make-hook))
(else
(apply bad-throw key args)))))))
- ;; Note that having just `lazy-handler-dispatch'
+ ;; Note that having just `pre-unwind-handler-dispatch'
;; here is connected with the mechanism that
;; produces a nice backtrace upon error. If, for
;; example, this is replaced with (lambda args
- ;; (apply lazy-handler-dispatch args)), the stack
+ ;; (apply pre-unwind-handler-dispatch args)), the stack
;; cutting (in save-stack) goes wrong and ends up
;; saving no stack at all, so there is no
;; backtrace.
- lazy-handler-dispatch)))
+ pre-unwind-handler-dispatch)))
(if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg)
;;; 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))))
(if (symbol? first)
(car rest)
`(lambda ,(cdr first) ,@rest))))
- `(eval-case
- ((load-toplevel)
- (define ,name (defmacro:transformer ,transformer)))
- (else
- (error "define-macro can only be used at the top level")))))
+ `(eval-when
+ (eval load compile)
+ (define ,name (defmacro:transformer ,transformer)))))
-(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")))))
-
\f
;;; {While}
;; The inner `do' loop avoids re-establishing a catch every iteration,
;; that's only necessary if continue is actually used. A new key is
;; generated every time, so break and continue apply to their originating
-;; `while' even when recursing. `while-helper' is an easy way to keep the
-;; `key' binding away from the cond and body code.
-;;
-;; FIXME: This is supposed to have an `unquote' on the `do' the same used
-;; for lambda and not, so as to protect against any user rebinding of that
-;; symbol, but unfortunately an unquote breaks with ice-9 syncase, eg.
+;; `while' even when recursing.
;;
-;; (use-modules (ice-9 syncase))
-;; (while #f)
-;; => ERROR: invalid syntax ()
-;;
-;; This is probably a bug in syncase.
+;; FIXME: This macro is unintentionally unhygienic with respect to let,
+;; make-symbol, do, throw, catch, lambda, and not.
;;
(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 ((keyvar (make-symbol "while-keyvar")))
+ `(let ((,keyvar (make-symbol "while-key")))
+ (do ()
+ ((catch ,keyvar
+ (lambda ()
+ (let ((break (lambda () (throw ,keyvar #t)))
+ (continue (lambda () (throw ,keyvar #f))))
+ (do ()
+ ((not ,cond))
+ ,@body)
+ #t))
+ (lambda (key arg)
+ arg)))))))
\f
;; Return a list of expressions that evaluate to the appropriate
;; arguments for resolve-interface according to SPEC.
+(eval-when
+ (compile)
+ (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)
(cddr args))))))
(defmacro define-module args
- `(eval-case
- ((load-toplevel)
- (let ((m (process-define-module
- (list ,@(compile-define-module-args args)))))
- (set-current-module m)
- m))
- (else
- (error "define-module can only be used at the top level"))))
+ `(eval-when
+ (eval load compile)
+ (let ((m (process-define-module
+ (list ,@(compile-define-module-args args)))))
+ (set-current-module m)
+ m)))
;; The guts of the use-modules macro. Add the interfaces of the named
;; modules to the use-list of the current module, in order.
(module-use-interfaces! (current-module) interfaces)))))
(defmacro use-modules modules
- `(eval-case
- ((load-toplevel)
- (process-use-modules
- (list ,@(map (lambda (m)
- `(list ,@(compile-interface-spec m)))
- modules)))
- *unspecified*)
- (else
- (error "use-modules can only be used at the top level"))))
+ `(eval-when
+ (eval load compile)
+ (process-use-modules
+ (list ,@(map (lambda (m)
+ `(list ,@(compile-interface-spec m)))
+ modules)))
+ *unspecified*))
(defmacro use-syntax (spec)
- `(eval-case
- ((load-toplevel)
+ `(eval-when
+ (eval load compile)
,@(if (pair? spec)
`((process-use-modules (list
(list ,@(compile-interface-spec spec))))
(set-module-transformer! (current-module)
,(car (last-pair spec))))
`((set-module-transformer! (current-module) ,spec)))
- *unspecified*)
- (else
- (error "use-syntax can only be used at the top level"))))
+ *unspecified*))
;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
;; as soon as guile supports hygienic macros.
(let ((name (defined-name (car args))))
`(begin
(define-private ,@args)
- (eval-case ((load-toplevel) (export ,name))))))))
+ (export ,name))))))
(defmacro defmacro-public args
(define (syntax)
(#t
(let ((name (defined-name (car args))))
`(begin
- (eval-case ((load-toplevel) (export-syntax ,name)))
+ (export-syntax ,name)
(defmacro ,@args))))))
;; Export a local variable
names)))
(defmacro export names
- `(eval-case
- ((load-toplevel)
- (call-with-deferred-observers
- (lambda ()
- (module-export! (current-module) ',names))))
- (else
- (error "export can only be used at the top level"))))
+ `(call-with-deferred-observers
+ (lambda ()
+ (module-export! (current-module) ',names))))
(defmacro re-export names
- `(eval-case
- ((load-toplevel)
- (call-with-deferred-observers
- (lambda ()
- (module-re-export! (current-module) ',names))))
- (else
- (error "re-export can only be used at the top level"))))
+ `(call-with-deferred-observers
+ (lambda ()
+ (module-re-export! (current-module) ',names))))
(defmacro export-syntax names
`(export ,@names))
\f
+;;; {Compiler interface}
+;;;
+;;; The full compiler interface can be found in (system). Here we put a
+;;; few useful procedures into the global namespace.
+
+(module-autoload! the-scm-module
+ '(system base compile)
+ '(compile
+ compile-time-environment))
+
+
+\f
+
;;; {Parameters}
;;;
;; 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")
;; the protected thunk.
(lambda ()
- (let ((status (scm-style-repl)))
+ (let ((status (start-repl 'scheme)))
(run-hook exit-hook)
status))
(provided? sym)))
(begin-deprecated
- (primitive-load-path "ice-9/deprecated.scm"))
+ (primitive-load-path "ice-9/deprecated"))
\f
(define (debug-on-error syms)
"Enable or disable debug on error."
- (set! lazy-handler-dispatch
+ (set! pre-unwind-handler-dispatch
(if syms
(lambda (key . args)
(if (memq key syms)
(begin
- (debug-stack (make-stack #t lazy-handler-dispatch)
+ (debug-stack (make-stack #t pre-unwind-handler-dispatch)
#:with-introduction
#:continuable)
(throw 'abort key)))
- (apply default-lazy-handler key args))
- default-lazy-handler)))
+ (apply default-pre-unwind-handler key args))
+ default-pre-unwind-handler)))
;;; (ice-9 debugger) ends here.
--- /dev/null
+;;;; (ice-9 debugging breakpoints) -- practical breakpoints
+
+;;; Copyright (C) 2005 Neil Jerram
+;;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;;; This module provides a practical interface for setting and
+;;; manipulating breakpoints.
+
+(define-module (ice-9 debugging breakpoints)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 ls)
+ #:use-module (ice-9 optargs)
+ #:use-module (ice-9 regex)
+ #:use-module (oop goops)
+ #:use-module (ice-9 debugging ice-9-debugger-extensions)
+ #:use-module (ice-9 debugging traps)
+ #:use-module (ice-9 debugging trc)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:export (break-in
+ break-at
+ default-breakpoint-behaviour
+ delete-breakpoint
+ for-each-breakpoint
+ setup-before-load
+ setup-after-load
+ setup-after-read
+ setup-after-eval))
+
+;; If the running Guile does not provide before- and after- load hooks
+;; itself, install them using the (ice-9 debugging load-hooks) module.
+(or (defined? 'after-load-hook)
+ (begin
+ (use-modules (ice-9 debugging load-hooks))
+ (install-load-hooks)))
+
+;; Getter/setter for default breakpoint behaviour.
+(define default-breakpoint-behaviour
+ (let ((behaviour debug-trap))
+ (make-procedure-with-setter
+ ;; Getter: return current default behaviour.
+ (lambda ()
+ behaviour)
+ ;; Setter: set default behaviour to given procedure.
+ (lambda (new-behaviour)
+ (set! behaviour new-behaviour)))))
+
+;; Base class for breakpoints. (We don't need to use GOOPS to
+;; represent breakpoints, but it's a nice way to describe a composite
+;; object.)
+(define-class <breakpoint> ()
+ ;; This breakpoint's trap options, which include its behaviour.
+ (trap-options #:init-keyword #:trap-options)
+ ;; All the traps relating to this breakpoint.
+ (traps #:init-value '())
+ ;; Observer. This is a procedure that is called when the breakpoint
+ ;; trap list changes.
+ (observer #:init-value #f))
+
+;; Noop base class definitions of all the possible setup methods.
+(define-method (setup-before-load (bp <breakpoint>) filename)
+ *unspecified*)
+(define-method (setup-after-load (bp <breakpoint>) filename)
+ *unspecified*)
+(define-method (setup-after-read (bp <breakpoint>) x)
+ *unspecified*)
+(define-method (setup-after-eval (bp <breakpoint>) filename)
+ *unspecified*)
+
+;; Call the breakpoint's observer, if it has one.
+(define-method (call-observer (bp <breakpoint>))
+ (cond ((slot-ref bp 'observer)
+ =>
+ (lambda (proc)
+ (proc)))))
+
+;; Delete a breakpoint.
+(define (delete-breakpoint bp)
+ ;; Remove this breakpoint from the global list.
+ (set! breakpoints (delq! bp breakpoints))
+ ;; Uninstall and discard all its traps.
+ (for-each uninstall-trap (slot-ref bp 'traps))
+ (slot-set! bp 'traps '()))
+
+;; Class for `break-in' breakpoints.
+(define-class <break-in> (<breakpoint>)
+ ;; The name of the procedure to break in.
+ (procedure-name #:init-keyword #:procedure-name)
+ ;; The name of the module or file that the procedure is defined in.
+ ;; A module name is a list of symbols that exactly names the
+ ;; relevant module. A file name is a string, which can in fact be
+ ;; any substring of the relevant full file name.
+ (module-or-file-name #:init-keyword #:module-or-file-name))
+
+;; Class for `break-at' breakpoints.
+(define-class <break-at> (<breakpoint>)
+ ;; The name of the file to break in. This is a string, which can in
+ ;; fact be any substring of the relevant full file name.
+ (file-name #:init-keyword #:file-name)
+ ;; Line and column number to break at.
+ (line #:init-keyword #:line)
+ (column #:init-keyword #:column))
+
+;; Global list of non-deleted breakpoints.
+(define breakpoints '())
+
+;; Add to the above list.
+(define-method (add-to-global-breakpoint-list (bp <breakpoint>))
+ (set! breakpoints (append! breakpoints (list bp))))
+
+;; break-in: create a `break-in' breakpoint.
+(define (break-in procedure-name . options)
+ ;; Sort out the optional args.
+ (let* ((module-or-file-name+options
+ (cond ((and (not (null? options))
+ (or (string? (car options))
+ (list? (car options))))
+ options)
+ (else
+ (cons (module-name (current-module)) options))))
+ (module-or-file-name (car module-or-file-name+options))
+ (trap-options (cdr module-or-file-name+options))
+ ;; Create the new breakpoint object.
+ (bp (make <break-in>
+ #:procedure-name procedure-name
+ #:module-or-file-name module-or-file-name
+ #:trap-options (if (memq #:behaviour trap-options)
+ trap-options
+ (cons* #:behaviour
+ (default-breakpoint-behaviour)
+ trap-options)))))
+ ;; Add it to the global breakpoint list.
+ (add-to-global-breakpoint-list bp)
+ ;; Set the new breakpoint, if possible, in already loaded code.
+ (set-in-existing-code bp)
+ ;; Return the breakpoint object to our caller.
+ bp))
+
+;; break-at: create a `break-at' breakpoint.
+(define (break-at file-name line column . trap-options)
+ ;; Create the new breakpoint object.
+ (let* ((bp (make <break-at>
+ #:file-name file-name
+ #:line line
+ #:column column
+ #:trap-options (if (memq #:behaviour trap-options)
+ trap-options
+ (cons* #:behaviour
+ (default-breakpoint-behaviour)
+ trap-options)))))
+ ;; Add it to the global breakpoint list.
+ (add-to-global-breakpoint-list bp)
+ ;; Set the new breakpoint, if possible, in already loaded code.
+ (set-in-existing-code bp)
+ ;; Return the breakpoint object to our caller.
+ bp))
+
+;; Set a `break-in' breakpoint in already loaded code, if possible.
+(define-method (set-in-existing-code (bp <break-in>))
+ ;; Get the module or file name that was specified for this
+ ;; breakpoint.
+ (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
+ ;; Handling is simpler for a module name.
+ (cond ((list? module-or-file-name)
+ ;; See if the named module exists yet.
+ (let ((m (module-if-already-loaded module-or-file-name)))
+ (maybe-break-in-module-proc m bp)))
+ ((string? module-or-file-name)
+ ;; Try all loaded modules.
+ (or-map (lambda (m)
+ (maybe-break-in-module-proc m bp))
+ (all-loaded-modules)))
+ (else
+ (error "Bad module-or-file-name:" module-or-file-name)))))
+
+(define (make-observer bp trap)
+ (lambda (event)
+ (trap-target-gone bp trap)))
+
+;; Set a `break-at' breakpoint in already loaded code, if possible.
+(define-method (set-in-existing-code (bp <break-at>) . code)
+ ;; Procedure to install a source trap on each expression that we
+ ;; find matching this breakpoint.
+ (define (install-source-trap x)
+ (or (or-map (lambda (trap)
+ (and (is-a? trap <source-trap>)
+ (eq? (slot-ref trap 'expression) x)))
+ (slot-ref bp 'traps))
+ (let ((trap (apply make <source-trap>
+ #:expression x
+ (slot-ref bp 'trap-options))))
+ (slot-set! trap 'observer (make-observer bp trap))
+ (install-trap trap)
+ (trc 'install-source-trap (object-address trap) (object-address x))
+ (trap-installed bp trap #t))))
+ ;; Scan the source whash, and install a trap on all code matching
+ ;; this breakpoint.
+ (trc 'set-in-existing-code (length code))
+ (if (null? code)
+ (scan-source-whash (slot-ref bp 'file-name)
+ (slot-ref bp 'line)
+ (slot-ref bp 'column)
+ install-source-trap)
+ (scan-code (car code)
+ (slot-ref bp 'file-name)
+ (slot-ref bp 'line)
+ (slot-ref bp 'column)
+ install-source-trap)))
+
+;; Temporary implementation of scan-source-whash - this _really_ needs
+;; to be implemented in C.
+(define (scan-source-whash file-name line column proc)
+ ;; Procedure to call for each source expression in the whash.
+ (define (folder x props acc)
+ (if (and (= line (source-property x 'line))
+ (= column (source-property x 'column))
+ (let ((fn (source-property x 'filename)))
+ (trc 'scan-source-whash fn)
+ (and (string? fn)
+ (string-contains fn file-name))))
+ (proc x)))
+ ;; Tracing.
+ (trc 'scan-source-whash file-name line column)
+ ;; Apply this procedure to the whash.
+ (hash-fold folder 0 source-whash))
+
+(define (scan-code x file-name line column proc)
+ (trc 'scan-code file-name line column)
+ (if (pair? x)
+ (begin
+ (if (and (eq? line (source-property x 'line))
+ (eq? column (source-property x 'column))
+ (let ((fn (source-property x 'filename)))
+ (trc 'scan-code fn)
+ (and (string? fn)
+ (string-contains fn file-name))))
+ (proc x))
+ (scan-code (car x) file-name line column proc)
+ (scan-code (cdr x) file-name line column proc))))
+
+;; If a module named MODULE-NAME has been loaded, return its module
+;; object; otherwise return #f.
+(define (module-if-already-loaded module-name)
+ (nested-ref the-root-module (append '(app modules) module-name)))
+
+;; Construct and return a list of all loaded modules.
+(define (all-loaded-modules)
+ ;; This is the list that accumulates known modules. It has to be
+ ;; defined outside the following functions, and accumulated using
+ ;; set!, so as to avoid infinite loops - because of the fact that
+ ;; all non-pure modules have a variable `app'.
+ (define known-modules '())
+ ;; Return an alist of submodules of the given PARENT-MODULE-NAME.
+ ;; Each element of the alist is (NAME . MODULE), where NAME is the
+ ;; module's leaf name (i.e. relative to PARENT-MODULE-NAME) and
+ ;; MODULE is the module object. By a "submodule of a parent
+ ;; module", we mean any module value that is bound to a symbol in
+ ;; the parent module, and which is not an interface module.
+ (define (direct-submodules parent-module-name)
+ (filter (lambda (name+value)
+ (and (module? (cdr name+value))
+ (not (eq? (module-kind (cdr name+value)) 'interface))))
+ (map (lambda (name)
+ (cons name (local-ref (append parent-module-name
+ (list name)))))
+ (cdar (lls parent-module-name)))))
+ ;; Add all submodules (direct and indirect) of the module named
+ ;; PARENT-MODULE-NAME to `known-modules', if not already there.
+ (define (add-submodules-of parent-module-name)
+ (let ((ds (direct-submodules parent-module-name)))
+ (for-each
+ (lambda (name+module)
+ (or (memq (cdr name+module) known-modules)
+ (begin
+ (set! known-modules (cons (cdr name+module) known-modules))
+ (add-submodules-of (append parent-module-name
+ (list (car name+module)))))))
+ ds)))
+ ;; Add submodules recursively, starting from the root of all
+ ;; modules.
+ (add-submodules-of '(app modules))
+ ;; Return the result.
+ known-modules)
+
+;; Before-load setup for `break-at' breakpoints.
+(define-method (setup-before-load (bp <break-at>) filename)
+ (let ((trap (apply make <location-trap>
+ #:file-regexp (regexp-quote (slot-ref bp 'file-name))
+ #:line (slot-ref bp 'line)
+ #:column (slot-ref bp 'column)
+ (slot-ref bp 'trap-options))))
+ (install-trap trap)
+ (trap-installed bp trap #f)
+ (letrec ((uninstaller
+ (lambda (file-name)
+ (uninstall-trap trap)
+ (remove-hook! after-load-hook uninstaller))))
+ (add-hook! after-load-hook uninstaller))))
+
+;; After-load setup for `break-in' breakpoints.
+(define-method (setup-after-load (bp <break-in>) filename)
+ ;; Get the module that the loaded file created or was loaded into,
+ ;; and the module or file name that were specified for this
+ ;; breakpoint.
+ (let ((m (current-module))
+ (module-or-file-name (slot-ref bp 'module-or-file-name)))
+ ;; Decide whether the breakpoint spec matches this load.
+ (if (or (and (string? module-or-file-name)
+ (string-contains filename module-or-file-name))
+ (and (list? module-or-file-name)
+ (equal? (module-name (current-module)) module-or-file-name)))
+ ;; It does, so try to install the breakpoint.
+ (maybe-break-in-module-proc m bp))))
+
+;; After-load setup for `break-at' breakpoints.
+(define-method (setup-after-load (bp <break-at>) filename)
+ (if (string-contains filename (slot-ref bp 'file-name))
+ (set-in-existing-code bp)))
+
+(define (maybe-break-in-module-proc m bp)
+ "If module M defines a procedure matching the specification of
+breakpoint BP, install a trap on it."
+ (let ((proc (module-ref m (slot-ref bp 'procedure-name) #f)))
+ (if (and proc
+ (procedure? proc)
+ (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
+ (if (string? module-or-file-name)
+ (source-file-matches (procedure-source proc)
+ module-or-file-name)
+ #t))
+ (not (or-map (lambda (trap)
+ (and (is-a? trap <procedure-trap>)
+ (eq? (slot-ref trap 'procedure) proc)))
+ (slot-ref bp 'traps))))
+ ;; There is, so install a <procedure-trap> on it.
+ (letrec ((trap (apply make <procedure-trap>
+ #:procedure proc
+ (slot-ref bp 'trap-options))))
+ (slot-set! trap 'observer (make-observer bp trap))
+ (install-trap trap)
+ (trap-installed bp trap #t)
+ ;; Tell caller that we installed a trap.
+ #t)
+ ;; Tell caller that we did not install a trap.
+ #f)))
+
+;; After-read setup for `break-at' breakpoints.
+(define-method (setup-after-read (bp <break-at>) x)
+ (set-in-existing-code bp x))
+
+;; Common code for associating a newly created and installed trap with
+;; a breakpoint object.
+(define (trap-installed bp trap record?)
+ (if record?
+ ;; Remember this trap in the breakpoint object.
+ (slot-set! bp 'traps (append! (slot-ref bp 'traps) (list trap))))
+ ;; Update the breakpoint status.
+ (call-observer bp))
+
+;; Common code for handling when the target of one of a breakpoint's
+;; traps is being GC'd.
+(define (trap-target-gone bp trap)
+ (trc 'trap-target-gone (object-address trap))
+ ;; Remove this trap from the breakpoint's list.
+ (slot-set! bp 'traps (delq! trap (slot-ref bp 'traps)))
+ ;; Update the breakpoint status.
+ (call-observer bp))
+
+(define (source-file-matches source file-name)
+ "Return #t if any of the expressions in SOURCE have a 'filename
+source property that includes FILE-NAME; otherwise return #f."
+ (and (pair? source)
+ (or (let ((source-file-name (source-property source 'filename)))
+ (and source-file-name
+ (string? source-file-name)
+ (string-contains source-file-name file-name)))
+ (let loop ((source source))
+ (and (pair? source)
+ (or (source-file-matches (car source) file-name)
+ (loop (cdr source))))))))
+
+;; Install load hook functions.
+(add-hook! before-load-hook
+ (lambda (fn)
+ (for-each-breakpoint setup-before-load fn)))
+
+(add-hook! after-load-hook
+ (lambda (fn)
+ (for-each-breakpoint setup-after-load fn)))
+
+;;; Apply generic function GF to each breakpoint, passing the
+;;; breakpoint object and ARGS as args on each call.
+(define (for-each-breakpoint gf . args)
+ (for-each (lambda (bp)
+ (apply gf bp args))
+ breakpoints))
+
+;; Make sure that recording of source positions is enabled. Without
+;; this break-at breakpoints will obviously not work.
+(read-enable 'positions)
+
+;;; (ice-9 debugging breakpoints) ends here.
--- /dev/null
+
+(define-module (ice-9 debugging load-hooks)
+ #:export (before-load-hook
+ after-load-hook
+ install-load-hooks
+ uninstall-load-hooks))
+
+;; real-primitive-load: holds the real (C-implemented) definition of
+;; primitive-load, when the load hooks are installed.
+(define real-primitive-load #f)
+
+;; The load hooks themselves. These are called with one argument, the
+;; name of the file concerned.
+(define before-load-hook (make-hook 1))
+(define after-load-hook (make-hook 1))
+
+;; primitive-load-with-hooks: our new definition for primitive-load.
+(define (primitive-load-with-hooks filename)
+ (run-hook before-load-hook filename)
+ (real-primitive-load filename)
+ (run-hook after-load-hook filename))
+
+(define (install-load-hooks)
+ (if real-primitive-load
+ (error "load hooks are already installed"))
+ (set! real-primitive-load primitive-load)
+ (set! primitive-load primitive-load-with-hooks))
+
+(define (uninstall-load-hooks)
+ (or real-primitive-load
+ (error "load hooks are not installed"))
+ (set! primitive-load real-primitive-load)
+ (set! real-primitive-load #f))
trap-ordering
behaviour-ordering
throw->trap-context
- on-lazy-handler-dispatch
+ on-pre-unwind-handler-dispatch
;; Interface for authors of new <trap> subclasses.
<trap-context>
<trap>
;;; same code for certain events that are trap-like, but not actually
;;; traps in the sense of the calls made by libguile's evaluator.
-;;; The main example of this is when an error is signalled. Guile
-;;; doesn't yet have a 100% reliable way of hooking into errors, but
-;;; in practice most errors go through a lazy-catch whose handler is
-;;; lazy-handler-dispatch (defined in ice-9/boot-9.scm), which in turn
-;;; calls default-lazy-handler. So we can present most errors as
-;;; pseudo-traps by modifying default-lazy-handler.
+;;; The main example of this is when an error is signalled. Guile
+;;; doesn't yet have a 100% reliable way of hooking into errors, but in
+;;; practice most errors go through a catch whose pre-unwind handler is
+;;; pre-unwind-handler-dispatch (defined in ice-9/boot-9.scm), which in
+;;; turn calls default-pre-unwind-handler. So we can present most errors
+;;; as pseudo-traps by modifying default-pre-unwind-handler.
-(define default-default-lazy-handler default-lazy-handler)
+(define default-default-pre-unwind-handler default-pre-unwind-handler)
(define (throw->trap-context key args . stack-args)
(let ((ctx (make <trap-context>
(apply make-stack #t stack-args))))
ctx))
-(define (on-lazy-handler-dispatch behaviour . ignored-keys)
- (set! default-lazy-handler
+(define (on-pre-unwind-handler-dispatch behaviour . ignored-keys)
+ (set! default-pre-unwind-handler
(if behaviour
(lambda (key . args)
(or (memq key ignored-keys)
(behaviour (throw->trap-context key
args
- lazy-handler-dispatch)))
- (apply default-default-lazy-handler key args))
- default-default-lazy-handler)))
+ pre-unwind-handler-dispatch)))
+ (apply default-default-pre-unwind-handler key args))
+ default-default-pre-unwind-handler)))
;;; {Trap Classes}
(define (list->uniform-vector prot lst)
(list->uniform-array 1 prot lst))
+
+(define-macro (eval-case . clauses)
+ (issue-deprecation-warning
+ "`eval-case' is deprecated. Use `eval-when' instead.")
+ ;; Practically speaking, eval-case only had load-toplevel and else as
+ ;; conditions.
+ (cond
+ ((assoc-ref clauses '(load-toplevel))
+ => (lambda (exps)
+ ;; the *unspecified so that non-toplevel definitions will be
+ ;; caught
+ `(begin *unspecified* . ,exps)))
+ ((assoc-ref clauses 'else)
+ => (lambda (exps)
+ `(begin *unspecified* . ,exps)))
+ (else
+ `(begin))))
(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)
(and transformer
(proc-doc transformer))))
(object-property object 'documentation)
+ (and (program? object)
+ (program-documentation object))
(and (procedure? object)
(not (closure? object))
(procedure-name object)
-;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc.
+;;; Copyright (C) 1998, 2001, 2006, 2009 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
:use-module ((ice-9 common-list) :select (some remove-if-not))
:export (getopt-long option-ref))
-(define option-spec-fields '(name
- value
- required?
- single-char
- predicate
- value-policy))
+(eval-when (eval load compile)
+ ;; This binding is used both at compile-time and run-time.
+ (define option-spec-fields '(name
+ value
+ required?
+ single-char
+ predicate
+ value-policy)))
(define option-spec (make-record-type 'option-spec option-spec-fields))
(define make-option-spec (record-constructor option-spec option-spec-fields))
-(define (define-one-option-spec-field-accessor field)
- `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
- (record-accessor option-spec ',field)))
+(eval-when (eval load compile)
+ ;; The following procedures are used only at compile-time when expanding
+ ;; `define-all-option-spec-accessors/modifiers' (see below).
-(define (define-one-option-spec-field-modifier field)
- `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
- (record-modifier option-spec ',field)))
+ (define (define-one-option-spec-field-accessor field)
+ `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
+ (record-accessor option-spec ',field)))
+
+ (define (define-one-option-spec-field-modifier field)
+ `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
+ (record-modifier option-spec ',field))))
(defmacro define-all-option-spec-accessors/modifiers ()
`(begin
locale-yes-regexp locale-no-regexp))
-(load-extension "libguile-i18n-v-0" "scm_init_i18n")
+(eval-when (eval load compile)
+ (load-extension "libguile-i18n-v-0" "scm_init_i18n"))
\f
;;;
=> 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)))))
--- /dev/null
+(letrec ((syntmp-lambda-var-list-151 (lambda (syntmp-vars-536) (let syntmp-lvl-537 ((syntmp-vars-538 syntmp-vars-536) (syntmp-ls-539 (quote ())) (syntmp-w-540 (quote (())))) (cond ((pair? syntmp-vars-538) (syntmp-lvl-537 (cdr syntmp-vars-538) (cons (syntmp-wrap-130 (car syntmp-vars-538) syntmp-w-540) syntmp-ls-539) syntmp-w-540)) ((syntmp-id?-102 syntmp-vars-538) (cons (syntmp-wrap-130 syntmp-vars-538 syntmp-w-540) syntmp-ls-539)) ((null? syntmp-vars-538) syntmp-ls-539) ((syntmp-syntax-object?-88 syntmp-vars-538) (syntmp-lvl-537 (syntmp-syntax-object-expression-89 syntmp-vars-538) syntmp-ls-539 (syntmp-join-wraps-121 syntmp-w-540 (syntmp-syntax-object-wrap-90 syntmp-vars-538)))) ((annotation? syntmp-vars-538) (syntmp-lvl-537 (annotation-expression syntmp-vars-538) syntmp-ls-539 syntmp-w-540)) (else (cons syntmp-vars-538 syntmp-ls-539)))))) (syntmp-gen-var-150 (lambda (syntmp-id-541) (let ((syntmp-id-542 (if (syntmp-syntax-object?-88 syntmp-id-541) (syntmp-syntax-object-expression-89 syntmp-id-541) syntmp-id-541))) (if (annotation? syntmp-id-542) (syntmp-build-annotated-81 (annotation-source syntmp-id-542) (gensym (symbol->string (annotation-expression syntmp-id-542)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-542))))))) (syntmp-strip-149 (lambda (syntmp-x-543 syntmp-w-544) (if (memq (quote top) (syntmp-wrap-marks-105 syntmp-w-544)) (if (or (annotation? syntmp-x-543) (and (pair? syntmp-x-543) (annotation? (car syntmp-x-543)))) (syntmp-strip-annotation-148 syntmp-x-543 #f) syntmp-x-543) (let syntmp-f-545 ((syntmp-x-546 syntmp-x-543)) (cond ((syntmp-syntax-object?-88 syntmp-x-546) (syntmp-strip-149 (syntmp-syntax-object-expression-89 syntmp-x-546) (syntmp-syntax-object-wrap-90 syntmp-x-546))) ((pair? syntmp-x-546) (let ((syntmp-a-547 (syntmp-f-545 (car syntmp-x-546))) (syntmp-d-548 (syntmp-f-545 (cdr syntmp-x-546)))) (if (and (eq? syntmp-a-547 (car syntmp-x-546)) (eq? syntmp-d-548 (cdr syntmp-x-546))) syntmp-x-546 (cons syntmp-a-547 syntmp-d-548)))) ((vector? syntmp-x-546) (let ((syntmp-old-549 (vector->list syntmp-x-546))) (let ((syntmp-new-550 (map syntmp-f-545 syntmp-old-549))) (if (andmap eq? syntmp-old-549 syntmp-new-550) syntmp-x-546 (list->vector syntmp-new-550))))) (else syntmp-x-546)))))) (syntmp-strip-annotation-148 (lambda (syntmp-x-551 syntmp-parent-552) (cond ((pair? syntmp-x-551) (let ((syntmp-new-553 (cons #f #f))) (begin (if syntmp-parent-552 (set-annotation-stripped! syntmp-parent-552 syntmp-new-553)) (set-car! syntmp-new-553 (syntmp-strip-annotation-148 (car syntmp-x-551) #f)) (set-cdr! syntmp-new-553 (syntmp-strip-annotation-148 (cdr syntmp-x-551) #f)) syntmp-new-553))) ((annotation? syntmp-x-551) (or (annotation-stripped syntmp-x-551) (syntmp-strip-annotation-148 (annotation-expression syntmp-x-551) syntmp-x-551))) ((vector? syntmp-x-551) (let ((syntmp-new-554 (make-vector (vector-length syntmp-x-551)))) (begin (if syntmp-parent-552 (set-annotation-stripped! syntmp-parent-552 syntmp-new-554)) (let syntmp-loop-555 ((syntmp-i-556 (- (vector-length syntmp-x-551) 1))) (unless (syntmp-fx<-75 syntmp-i-556 0) (vector-set! syntmp-new-554 syntmp-i-556 (syntmp-strip-annotation-148 (vector-ref syntmp-x-551 syntmp-i-556) #f)) (syntmp-loop-555 (syntmp-fx--73 syntmp-i-556 1)))) syntmp-new-554))) (else syntmp-x-551)))) (syntmp-ellipsis?-147 (lambda (syntmp-x-557) (and (syntmp-nonsymbol-id?-101 syntmp-x-557) (syntmp-free-id=?-125 syntmp-x-557 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-146 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-145 (lambda (syntmp-expanded-558) (let ((syntmp-p-559 (syntmp-local-eval-hook-77 syntmp-expanded-558))) (if (procedure? syntmp-p-559) syntmp-p-559 (syntax-error syntmp-p-559 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-144 (lambda (syntmp-rec?-560 syntmp-e-561 syntmp-r-562 syntmp-w-563 syntmp-s-564 syntmp-k-565) ((lambda (syntmp-tmp-566) ((lambda (syntmp-tmp-567) (if syntmp-tmp-567 (apply (lambda (syntmp-_-568 syntmp-id-569 syntmp-val-570 syntmp-e1-571 syntmp-e2-572) (let ((syntmp-ids-573 syntmp-id-569)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-573)) (syntax-error syntmp-e-561 "duplicate bound keyword in") (let ((syntmp-labels-575 (syntmp-gen-labels-108 syntmp-ids-573))) (let ((syntmp-new-w-576 (syntmp-make-binding-wrap-119 syntmp-ids-573 syntmp-labels-575 syntmp-w-563))) (syntmp-k-565 (cons syntmp-e1-571 syntmp-e2-572) (syntmp-extend-env-96 syntmp-labels-575 (let ((syntmp-w-578 (if syntmp-rec?-560 syntmp-new-w-576 syntmp-w-563)) (syntmp-trans-r-579 (syntmp-macros-only-env-98 syntmp-r-562))) (map (lambda (syntmp-x-580) (cons (quote macro) (syntmp-eval-local-transformer-145 (syntmp-chi-138 syntmp-x-580 syntmp-trans-r-579 syntmp-w-578)))) syntmp-val-570)) syntmp-r-562) syntmp-new-w-576 syntmp-s-564)))))) syntmp-tmp-567) ((lambda (syntmp-_-582) (syntax-error (syntmp-source-wrap-131 syntmp-e-561 syntmp-w-563 syntmp-s-564))) syntmp-tmp-566))) (syntax-dispatch syntmp-tmp-566 (quote (any #(each (any any)) any . each-any))))) syntmp-e-561))) (syntmp-chi-lambda-clause-143 (lambda (syntmp-e-583 syntmp-c-584 syntmp-r-585 syntmp-w-586 syntmp-k-587) ((lambda (syntmp-tmp-588) ((lambda (syntmp-tmp-589) (if syntmp-tmp-589 (apply (lambda (syntmp-id-590 syntmp-e1-591 syntmp-e2-592) (let ((syntmp-ids-593 syntmp-id-590)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-593)) (syntax-error syntmp-e-583 "invalid parameter list in") (let ((syntmp-labels-595 (syntmp-gen-labels-108 syntmp-ids-593)) (syntmp-new-vars-596 (map syntmp-gen-var-150 syntmp-ids-593))) (syntmp-k-587 syntmp-new-vars-596 (syntmp-chi-body-142 (cons syntmp-e1-591 syntmp-e2-592) syntmp-e-583 (syntmp-extend-var-env-97 syntmp-labels-595 syntmp-new-vars-596 syntmp-r-585) (syntmp-make-binding-wrap-119 syntmp-ids-593 syntmp-labels-595 syntmp-w-586))))))) syntmp-tmp-589) ((lambda (syntmp-tmp-598) (if syntmp-tmp-598 (apply (lambda (syntmp-ids-599 syntmp-e1-600 syntmp-e2-601) (let ((syntmp-old-ids-602 (syntmp-lambda-var-list-151 syntmp-ids-599))) (if (not (syntmp-valid-bound-ids?-127 syntmp-old-ids-602)) (syntax-error syntmp-e-583 "invalid parameter list in") (let ((syntmp-labels-603 (syntmp-gen-labels-108 syntmp-old-ids-602)) (syntmp-new-vars-604 (map syntmp-gen-var-150 syntmp-old-ids-602))) (syntmp-k-587 (let syntmp-f-605 ((syntmp-ls1-606 (cdr syntmp-new-vars-604)) (syntmp-ls2-607 (car syntmp-new-vars-604))) (if (null? syntmp-ls1-606) syntmp-ls2-607 (syntmp-f-605 (cdr syntmp-ls1-606) (cons (car syntmp-ls1-606) syntmp-ls2-607)))) (syntmp-chi-body-142 (cons syntmp-e1-600 syntmp-e2-601) syntmp-e-583 (syntmp-extend-var-env-97 syntmp-labels-603 syntmp-new-vars-604 syntmp-r-585) (syntmp-make-binding-wrap-119 syntmp-old-ids-602 syntmp-labels-603 syntmp-w-586))))))) syntmp-tmp-598) ((lambda (syntmp-_-609) (syntax-error syntmp-e-583)) syntmp-tmp-588))) (syntax-dispatch syntmp-tmp-588 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-588 (quote (each-any any . each-any))))) syntmp-c-584))) (syntmp-chi-body-142 (lambda (syntmp-body-610 syntmp-outer-form-611 syntmp-r-612 syntmp-w-613) (let ((syntmp-r-614 (cons (quote ("placeholder" placeholder)) syntmp-r-612))) (let ((syntmp-ribcage-615 (syntmp-make-ribcage-109 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-616 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w-613) (cons syntmp-ribcage-615 (syntmp-wrap-subst-106 syntmp-w-613))))) (let syntmp-parse-617 ((syntmp-body-618 (map (lambda (syntmp-x-624) (cons syntmp-r-614 (syntmp-wrap-130 syntmp-x-624 syntmp-w-616))) syntmp-body-610)) (syntmp-ids-619 (quote ())) (syntmp-labels-620 (quote ())) (syntmp-vars-621 (quote ())) (syntmp-vals-622 (quote ())) (syntmp-bindings-623 (quote ()))) (if (null? syntmp-body-618) (syntax-error syntmp-outer-form-611 "no expressions in body") (let ((syntmp-e-625 (cdar syntmp-body-618)) (syntmp-er-626 (caar syntmp-body-618))) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-625 syntmp-er-626 (quote (())) #f syntmp-ribcage-615)) (lambda (syntmp-type-627 syntmp-value-628 syntmp-e-629 syntmp-w-630 syntmp-s-631) (let ((syntmp-t-632 syntmp-type-627)) (if (memv syntmp-t-632 (quote (define-form))) (let ((syntmp-id-633 (syntmp-wrap-130 syntmp-value-628 syntmp-w-630)) (syntmp-label-634 (syntmp-gen-label-107))) (let ((syntmp-var-635 (syntmp-gen-var-150 syntmp-id-633))) (begin (syntmp-extend-ribcage!-118 syntmp-ribcage-615 syntmp-id-633 syntmp-label-634) (syntmp-parse-617 (cdr syntmp-body-618) (cons syntmp-id-633 syntmp-ids-619) (cons syntmp-label-634 syntmp-labels-620) (cons syntmp-var-635 syntmp-vars-621) (cons (cons syntmp-er-626 (syntmp-wrap-130 syntmp-e-629 syntmp-w-630)) syntmp-vals-622) (cons (cons (quote lexical) syntmp-var-635) syntmp-bindings-623))))) (if (memv syntmp-t-632 (quote (define-syntax-form))) (let ((syntmp-id-636 (syntmp-wrap-130 syntmp-value-628 syntmp-w-630)) (syntmp-label-637 (syntmp-gen-label-107))) (begin (syntmp-extend-ribcage!-118 syntmp-ribcage-615 syntmp-id-636 syntmp-label-637) (syntmp-parse-617 (cdr syntmp-body-618) (cons syntmp-id-636 syntmp-ids-619) (cons syntmp-label-637 syntmp-labels-620) syntmp-vars-621 syntmp-vals-622 (cons (cons (quote macro) (cons syntmp-er-626 (syntmp-wrap-130 syntmp-e-629 syntmp-w-630))) syntmp-bindings-623)))) (if (memv syntmp-t-632 (quote (begin-form))) ((lambda (syntmp-tmp-638) ((lambda (syntmp-tmp-639) (if syntmp-tmp-639 (apply (lambda (syntmp-_-640 syntmp-e1-641) (syntmp-parse-617 (let syntmp-f-642 ((syntmp-forms-643 syntmp-e1-641)) (if (null? syntmp-forms-643) (cdr syntmp-body-618) (cons (cons syntmp-er-626 (syntmp-wrap-130 (car syntmp-forms-643) syntmp-w-630)) (syntmp-f-642 (cdr syntmp-forms-643))))) syntmp-ids-619 syntmp-labels-620 syntmp-vars-621 syntmp-vals-622 syntmp-bindings-623)) syntmp-tmp-639) (syntax-error syntmp-tmp-638))) (syntax-dispatch syntmp-tmp-638 (quote (any . each-any))))) syntmp-e-629) (if (memv syntmp-t-632 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-628 syntmp-e-629 syntmp-er-626 syntmp-w-630 syntmp-s-631 (lambda (syntmp-forms-645 syntmp-er-646 syntmp-w-647 syntmp-s-648) (syntmp-parse-617 (let syntmp-f-649 ((syntmp-forms-650 syntmp-forms-645)) (if (null? syntmp-forms-650) (cdr syntmp-body-618) (cons (cons syntmp-er-646 (syntmp-wrap-130 (car syntmp-forms-650) syntmp-w-647)) (syntmp-f-649 (cdr syntmp-forms-650))))) syntmp-ids-619 syntmp-labels-620 syntmp-vars-621 syntmp-vals-622 syntmp-bindings-623))) (if (null? syntmp-ids-619) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-651) (syntmp-chi-138 (cdr syntmp-x-651) (car syntmp-x-651) (quote (())))) (cons (cons syntmp-er-626 (syntmp-source-wrap-131 syntmp-e-629 syntmp-w-630 syntmp-s-631)) (cdr syntmp-body-618)))) (begin (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-619)) (syntax-error syntmp-outer-form-611 "invalid or duplicate identifier in definition")) (let syntmp-loop-652 ((syntmp-bs-653 syntmp-bindings-623) (syntmp-er-cache-654 #f) (syntmp-r-cache-655 #f)) (if (not (null? syntmp-bs-653)) (let ((syntmp-b-656 (car syntmp-bs-653))) (if (eq? (car syntmp-b-656) (quote macro)) (let ((syntmp-er-657 (cadr syntmp-b-656))) (let ((syntmp-r-cache-658 (if (eq? syntmp-er-657 syntmp-er-cache-654) syntmp-r-cache-655 (syntmp-macros-only-env-98 syntmp-er-657)))) (begin (set-cdr! syntmp-b-656 (syntmp-eval-local-transformer-145 (syntmp-chi-138 (cddr syntmp-b-656) syntmp-r-cache-658 (quote (()))))) (syntmp-loop-652 (cdr syntmp-bs-653) syntmp-er-657 syntmp-r-cache-658)))) (syntmp-loop-652 (cdr syntmp-bs-653) syntmp-er-cache-654 syntmp-r-cache-655))))) (set-cdr! syntmp-r-614 (syntmp-extend-env-96 syntmp-labels-620 syntmp-bindings-623 (cdr syntmp-r-614))) (syntmp-build-letrec-86 #f syntmp-vars-621 (map (lambda (syntmp-x-659) (syntmp-chi-138 (cdr syntmp-x-659) (car syntmp-x-659) (quote (())))) syntmp-vals-622) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-660) (syntmp-chi-138 (cdr syntmp-x-660) (car syntmp-x-660) (quote (())))) (cons (cons syntmp-er-626 (syntmp-source-wrap-131 syntmp-e-629 syntmp-w-630 syntmp-s-631)) (cdr syntmp-body-618)))))))))))))))))))))) (syntmp-chi-macro-141 (lambda (syntmp-p-661 syntmp-e-662 syntmp-r-663 syntmp-w-664 syntmp-rib-665) (letrec ((syntmp-rebuild-macro-output-666 (lambda (syntmp-x-667 syntmp-m-668) (cond ((pair? syntmp-x-667) (cons (syntmp-rebuild-macro-output-666 (car syntmp-x-667) syntmp-m-668) (syntmp-rebuild-macro-output-666 (cdr syntmp-x-667) syntmp-m-668))) ((syntmp-syntax-object?-88 syntmp-x-667) (let ((syntmp-w-669 (syntmp-syntax-object-wrap-90 syntmp-x-667))) (let ((syntmp-ms-670 (syntmp-wrap-marks-105 syntmp-w-669)) (syntmp-s-671 (syntmp-wrap-subst-106 syntmp-w-669))) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-667) (if (and (pair? syntmp-ms-670) (eq? (car syntmp-ms-670) #f)) (syntmp-make-wrap-104 (cdr syntmp-ms-670) (if syntmp-rib-665 (cons syntmp-rib-665 (cdr syntmp-s-671)) (cdr syntmp-s-671))) (syntmp-make-wrap-104 (cons syntmp-m-668 syntmp-ms-670) (if syntmp-rib-665 (cons syntmp-rib-665 (cons (quote shift) syntmp-s-671)) (cons (quote shift) syntmp-s-671)))))))) ((vector? syntmp-x-667) (let ((syntmp-n-672 (vector-length syntmp-x-667))) (let ((syntmp-v-673 (make-vector syntmp-n-672))) (let syntmp-doloop-674 ((syntmp-i-675 0)) (if (syntmp-fx=-74 syntmp-i-675 syntmp-n-672) syntmp-v-673 (begin (vector-set! syntmp-v-673 syntmp-i-675 (syntmp-rebuild-macro-output-666 (vector-ref syntmp-x-667 syntmp-i-675) syntmp-m-668)) (syntmp-doloop-674 (syntmp-fx+-72 syntmp-i-675 1)))))))) ((symbol? syntmp-x-667) (syntax-error syntmp-x-667 "encountered raw symbol in macro output")) (else syntmp-x-667))))) (syntmp-rebuild-macro-output-666 (syntmp-p-661 (syntmp-wrap-130 syntmp-e-662 (syntmp-anti-mark-117 syntmp-w-664))) (string #\m))))) (syntmp-chi-application-140 (lambda (syntmp-x-676 syntmp-e-677 syntmp-r-678 syntmp-w-679 syntmp-s-680) ((lambda (syntmp-tmp-681) ((lambda (syntmp-tmp-682) (if syntmp-tmp-682 (apply (lambda (syntmp-e0-683 syntmp-e1-684) (syntmp-build-annotated-81 syntmp-s-680 (cons syntmp-x-676 (map (lambda (syntmp-e-685) (syntmp-chi-138 syntmp-e-685 syntmp-r-678 syntmp-w-679)) syntmp-e1-684)))) syntmp-tmp-682) (syntax-error syntmp-tmp-681))) (syntax-dispatch syntmp-tmp-681 (quote (any . each-any))))) syntmp-e-677))) (syntmp-chi-expr-139 (lambda (syntmp-type-687 syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (let ((syntmp-t-693 syntmp-type-687)) (if (memv syntmp-t-693 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-692 syntmp-value-688) (if (memv syntmp-t-693 (quote (core external-macro))) (syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (lexical-call))) (syntmp-chi-application-140 (syntmp-build-annotated-81 (syntmp-source-annotation-93 (car syntmp-e-689)) syntmp-value-688) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (global-call))) (syntmp-chi-application-140 (syntmp-build-annotated-81 (syntmp-source-annotation-93 (car syntmp-e-689)) syntmp-value-688) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (constant))) (syntmp-build-data-82 syntmp-s-692 (syntmp-strip-149 (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) (quote (())))) (if (memv syntmp-t-693 (quote (global))) (syntmp-build-annotated-81 syntmp-s-692 syntmp-value-688) (if (memv syntmp-t-693 (quote (call))) (syntmp-chi-application-140 (syntmp-chi-138 (car syntmp-e-689) syntmp-r-690 syntmp-w-691) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (begin-form))) ((lambda (syntmp-tmp-694) ((lambda (syntmp-tmp-695) (if syntmp-tmp-695 (apply (lambda (syntmp-_-696 syntmp-e1-697 syntmp-e2-698) (syntmp-chi-sequence-132 (cons syntmp-e1-697 syntmp-e2-698) syntmp-r-690 syntmp-w-691 syntmp-s-692)) syntmp-tmp-695) (syntax-error syntmp-tmp-694))) (syntax-dispatch syntmp-tmp-694 (quote (any any . each-any))))) syntmp-e-689) (if (memv syntmp-t-693 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692 syntmp-chi-sequence-132) (if (memv syntmp-t-693 (quote (eval-when-form))) ((lambda (syntmp-tmp-700) ((lambda (syntmp-tmp-701) (if syntmp-tmp-701 (apply (lambda (syntmp-_-702 syntmp-x-703 syntmp-e1-704 syntmp-e2-705) (let ((syntmp-when-list-706 (syntmp-chi-when-list-135 syntmp-e-689 syntmp-x-703 syntmp-w-691))) (if (memq (quote eval) syntmp-when-list-706) (syntmp-chi-sequence-132 (cons syntmp-e1-704 syntmp-e2-705) syntmp-r-690 syntmp-w-691 syntmp-s-692) (syntmp-chi-void-146)))) syntmp-tmp-701) (syntax-error syntmp-tmp-700))) (syntax-dispatch syntmp-tmp-700 (quote (any each-any any . each-any))))) syntmp-e-689) (if (memv syntmp-t-693 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-130 syntmp-value-688 syntmp-w-691) "invalid context for definition of") (if (memv syntmp-t-693 (quote (syntax))) (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) "reference to pattern variable outside syntax form") (if (memv syntmp-t-693 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692)))))))))))))))))) (syntmp-chi-138 (lambda (syntmp-e-709 syntmp-r-710 syntmp-w-711) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-709 syntmp-r-710 syntmp-w-711 #f #f)) (lambda (syntmp-type-712 syntmp-value-713 syntmp-e-714 syntmp-w-715 syntmp-s-716) (syntmp-chi-expr-139 syntmp-type-712 syntmp-value-713 syntmp-e-714 syntmp-r-710 syntmp-w-715 syntmp-s-716))))) (syntmp-chi-top-137 (lambda (syntmp-e-717 syntmp-r-718 syntmp-w-719 syntmp-m-720 syntmp-esew-721) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-717 syntmp-r-718 syntmp-w-719 #f #f)) (lambda (syntmp-type-734 syntmp-value-735 syntmp-e-736 syntmp-w-737 syntmp-s-738) (let ((syntmp-t-739 syntmp-type-734)) (if (memv syntmp-t-739 (quote (begin-form))) ((lambda (syntmp-tmp-740) ((lambda (syntmp-tmp-741) (if syntmp-tmp-741 (apply (lambda (syntmp-_-742) (syntmp-chi-void-146)) syntmp-tmp-741) ((lambda (syntmp-tmp-743) (if syntmp-tmp-743 (apply (lambda (syntmp-_-744 syntmp-e1-745 syntmp-e2-746) (syntmp-chi-top-sequence-133 (cons syntmp-e1-745 syntmp-e2-746) syntmp-r-718 syntmp-w-737 syntmp-s-738 syntmp-m-720 syntmp-esew-721)) syntmp-tmp-743) (syntax-error syntmp-tmp-740))) (syntax-dispatch syntmp-tmp-740 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-740 (quote (any))))) syntmp-e-736) (if (memv syntmp-t-739 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-735 syntmp-e-736 syntmp-r-718 syntmp-w-737 syntmp-s-738 (lambda (syntmp-body-748 syntmp-r-749 syntmp-w-750 syntmp-s-751) (syntmp-chi-top-sequence-133 syntmp-body-748 syntmp-r-749 syntmp-w-750 syntmp-s-751 syntmp-m-720 syntmp-esew-721))) (if (memv syntmp-t-739 (quote (eval-when-form))) ((lambda (syntmp-tmp-752) ((lambda (syntmp-tmp-753) (if syntmp-tmp-753 (apply (lambda (syntmp-_-754 syntmp-x-755 syntmp-e1-756 syntmp-e2-757) (let ((syntmp-when-list-758 (syntmp-chi-when-list-135 syntmp-e-736 syntmp-x-755 syntmp-w-737)) (syntmp-body-759 (cons syntmp-e1-756 syntmp-e2-757))) (cond ((eq? syntmp-m-720 (quote e)) (if (memq (quote eval) syntmp-when-list-758) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote e) (quote (eval))) (syntmp-chi-void-146))) ((memq (quote load) syntmp-when-list-758) (if (or (memq (quote compile) syntmp-when-list-758) (and (eq? syntmp-m-720 (quote c&e)) (memq (quote eval) syntmp-when-list-758))) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote c&e) (quote (compile load))) (if (memq syntmp-m-720 (quote (c c&e))) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote c) (quote (load))) (syntmp-chi-void-146)))) ((or (memq (quote compile) syntmp-when-list-758) (and (eq? syntmp-m-720 (quote c&e)) (memq (quote eval) syntmp-when-list-758))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote e) (quote (eval)))) (syntmp-chi-void-146)) (else (syntmp-chi-void-146))))) syntmp-tmp-753) (syntax-error syntmp-tmp-752))) (syntax-dispatch syntmp-tmp-752 (quote (any each-any any . each-any))))) syntmp-e-736) (if (memv syntmp-t-739 (quote (define-syntax-form))) (let ((syntmp-n-762 (syntmp-id-var-name-124 syntmp-value-735 syntmp-w-737)) (syntmp-r-763 (syntmp-macros-only-env-98 syntmp-r-718))) (let ((syntmp-t-764 syntmp-m-720)) (if (memv syntmp-t-764 (quote (c))) (if (memq (quote compile) syntmp-esew-721) (let ((syntmp-e-765 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-765) (if (memq (quote load) syntmp-esew-721) syntmp-e-765 (syntmp-chi-void-146)))) (if (memq (quote load) syntmp-esew-721) (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)) (syntmp-chi-void-146))) (if (memv syntmp-t-764 (quote (c&e))) (let ((syntmp-e-766 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-766) syntmp-e-766)) (begin (if (memq (quote eval) syntmp-esew-721) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (syntmp-chi-void-146)))))) (if (memv syntmp-t-739 (quote (define-form))) (let ((syntmp-n-767 (syntmp-id-var-name-124 syntmp-value-735 syntmp-w-737))) (let ((syntmp-type-768 (syntmp-binding-type-94 (syntmp-lookup-99 syntmp-n-767 syntmp-r-718)))) (let ((syntmp-t-769 syntmp-type-768)) (if (memv syntmp-t-769 (quote (global))) (let ((syntmp-x-770 (syntmp-build-annotated-81 syntmp-s-738 (list (quote define) syntmp-n-767 (syntmp-chi-138 syntmp-e-736 syntmp-r-718 syntmp-w-737))))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-770)) syntmp-x-770)) (if (memv syntmp-t-769 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-130 syntmp-value-735 syntmp-w-737) "identifier out of context") (if (eq? syntmp-type-768 (quote external-macro)) (let ((syntmp-x-771 (syntmp-build-annotated-81 syntmp-s-738 (list (quote define) syntmp-n-767 (syntmp-chi-138 syntmp-e-736 syntmp-r-718 syntmp-w-737))))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-771)) syntmp-x-771)) (syntax-error (syntmp-wrap-130 syntmp-value-735 syntmp-w-737) "cannot define keyword at top level"))))))) (let ((syntmp-x-772 (syntmp-chi-expr-139 syntmp-type-734 syntmp-value-735 syntmp-e-736 syntmp-r-718 syntmp-w-737 syntmp-s-738))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-772)) syntmp-x-772)))))))))))) (syntmp-syntax-type-136 (lambda (syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-rib-777) (cond ((symbol? syntmp-e-773) (let ((syntmp-n-778 (syntmp-id-var-name-124 syntmp-e-773 syntmp-w-775))) (let ((syntmp-b-779 (syntmp-lookup-99 syntmp-n-778 syntmp-r-774))) (let ((syntmp-type-780 (syntmp-binding-type-94 syntmp-b-779))) (let ((syntmp-t-781 syntmp-type-780)) (if (memv syntmp-t-781 (quote (lexical))) (values syntmp-type-780 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-781 (quote (global))) (values syntmp-type-780 syntmp-n-778 syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-781 (quote (macro))) (syntmp-syntax-type-136 (syntmp-chi-macro-141 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-rib-777) syntmp-r-774 (quote (())) syntmp-s-776 syntmp-rib-777) (values syntmp-type-780 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-w-775 syntmp-s-776))))))))) ((pair? syntmp-e-773) (let ((syntmp-first-782 (car syntmp-e-773))) (if (syntmp-id?-102 syntmp-first-782) (let ((syntmp-n-783 (syntmp-id-var-name-124 syntmp-first-782 syntmp-w-775))) (let ((syntmp-b-784 (syntmp-lookup-99 syntmp-n-783 syntmp-r-774))) (let ((syntmp-type-785 (syntmp-binding-type-94 syntmp-b-784))) (let ((syntmp-t-786 syntmp-type-785)) (if (memv syntmp-t-786 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (global))) (values (quote global-call) syntmp-n-783 syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (macro))) (syntmp-syntax-type-136 (syntmp-chi-macro-141 (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-rib-777) syntmp-r-774 (quote (())) syntmp-s-776 syntmp-rib-777) (if (memv syntmp-t-786 (quote (core external-macro))) (values syntmp-type-785 (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (begin))) (values (quote begin-form) #f syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (define))) ((lambda (syntmp-tmp-787) ((lambda (syntmp-tmp-788) (if (if syntmp-tmp-788 (apply (lambda (syntmp-_-789 syntmp-name-790 syntmp-val-791) (syntmp-id?-102 syntmp-name-790)) syntmp-tmp-788) #f) (apply (lambda (syntmp-_-792 syntmp-name-793 syntmp-val-794) (values (quote define-form) syntmp-name-793 syntmp-val-794 syntmp-w-775 syntmp-s-776)) syntmp-tmp-788) ((lambda (syntmp-tmp-795) (if (if syntmp-tmp-795 (apply (lambda (syntmp-_-796 syntmp-name-797 syntmp-args-798 syntmp-e1-799 syntmp-e2-800) (and (syntmp-id?-102 syntmp-name-797) (syntmp-valid-bound-ids?-127 (syntmp-lambda-var-list-151 syntmp-args-798)))) syntmp-tmp-795) #f) (apply (lambda (syntmp-_-801 syntmp-name-802 syntmp-args-803 syntmp-e1-804 syntmp-e2-805) (values (quote define-form) (syntmp-wrap-130 syntmp-name-802 syntmp-w-775) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("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-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-130 (cons syntmp-args-803 (cons syntmp-e1-804 syntmp-e2-805)) syntmp-w-775)) (quote (())) syntmp-s-776)) syntmp-tmp-795) ((lambda (syntmp-tmp-807) (if (if syntmp-tmp-807 (apply (lambda (syntmp-_-808 syntmp-name-809) (syntmp-id?-102 syntmp-name-809)) syntmp-tmp-807) #f) (apply (lambda (syntmp-_-810 syntmp-name-811) (values (quote define-form) (syntmp-wrap-130 syntmp-name-811 syntmp-w-775) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("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-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-776)) syntmp-tmp-807) (syntax-error syntmp-tmp-787))) (syntax-dispatch syntmp-tmp-787 (quote (any any)))))) (syntax-dispatch syntmp-tmp-787 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-787 (quote (any any any))))) syntmp-e-773) (if (memv syntmp-t-786 (quote (define-syntax))) ((lambda (syntmp-tmp-812) ((lambda (syntmp-tmp-813) (if (if syntmp-tmp-813 (apply (lambda (syntmp-_-814 syntmp-name-815 syntmp-val-816) (syntmp-id?-102 syntmp-name-815)) syntmp-tmp-813) #f) (apply (lambda (syntmp-_-817 syntmp-name-818 syntmp-val-819) (values (quote define-syntax-form) syntmp-name-818 syntmp-val-819 syntmp-w-775 syntmp-s-776)) syntmp-tmp-813) (syntax-error syntmp-tmp-812))) (syntax-dispatch syntmp-tmp-812 (quote (any any any))))) syntmp-e-773) (values (quote call) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)))))))))))))) (values (quote call) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)))) ((syntmp-syntax-object?-88 syntmp-e-773) (syntmp-syntax-type-136 (syntmp-syntax-object-expression-89 syntmp-e-773) syntmp-r-774 (syntmp-join-wraps-121 syntmp-w-775 (syntmp-syntax-object-wrap-90 syntmp-e-773)) #f syntmp-rib-777)) ((annotation? syntmp-e-773) (syntmp-syntax-type-136 (annotation-expression syntmp-e-773) syntmp-r-774 syntmp-w-775 (annotation-source syntmp-e-773) syntmp-rib-777)) ((self-evaluating? syntmp-e-773) (values (quote constant) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)) (else (values (quote other) #f syntmp-e-773 syntmp-w-775 syntmp-s-776))))) (syntmp-chi-when-list-135 (lambda (syntmp-e-820 syntmp-when-list-821 syntmp-w-822) (let syntmp-f-823 ((syntmp-when-list-824 syntmp-when-list-821) (syntmp-situations-825 (quote ()))) (if (null? syntmp-when-list-824) syntmp-situations-825 (syntmp-f-823 (cdr syntmp-when-list-824) (cons (let ((syntmp-x-826 (car syntmp-when-list-824))) (cond ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-130 syntmp-x-826 syntmp-w-822) "invalid eval-when situation")))) syntmp-situations-825)))))) (syntmp-chi-install-global-134 (lambda (syntmp-name-827 syntmp-e-828) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-827) syntmp-e-828)))) (syntmp-chi-top-sequence-133 (lambda (syntmp-body-829 syntmp-r-830 syntmp-w-831 syntmp-s-832 syntmp-m-833 syntmp-esew-834) (syntmp-build-sequence-83 syntmp-s-832 (let syntmp-dobody-835 ((syntmp-body-836 syntmp-body-829) (syntmp-r-837 syntmp-r-830) (syntmp-w-838 syntmp-w-831) (syntmp-m-839 syntmp-m-833) (syntmp-esew-840 syntmp-esew-834)) (if (null? syntmp-body-836) (quote ()) (let ((syntmp-first-841 (syntmp-chi-top-137 (car syntmp-body-836) syntmp-r-837 syntmp-w-838 syntmp-m-839 syntmp-esew-840))) (cons syntmp-first-841 (syntmp-dobody-835 (cdr syntmp-body-836) syntmp-r-837 syntmp-w-838 syntmp-m-839 syntmp-esew-840)))))))) (syntmp-chi-sequence-132 (lambda (syntmp-body-842 syntmp-r-843 syntmp-w-844 syntmp-s-845) (syntmp-build-sequence-83 syntmp-s-845 (let syntmp-dobody-846 ((syntmp-body-847 syntmp-body-842) (syntmp-r-848 syntmp-r-843) (syntmp-w-849 syntmp-w-844)) (if (null? syntmp-body-847) (quote ()) (let ((syntmp-first-850 (syntmp-chi-138 (car syntmp-body-847) syntmp-r-848 syntmp-w-849))) (cons syntmp-first-850 (syntmp-dobody-846 (cdr syntmp-body-847) syntmp-r-848 syntmp-w-849)))))))) (syntmp-source-wrap-131 (lambda (syntmp-x-851 syntmp-w-852 syntmp-s-853) (syntmp-wrap-130 (if syntmp-s-853 (make-annotation syntmp-x-851 syntmp-s-853 #f) syntmp-x-851) syntmp-w-852))) (syntmp-wrap-130 (lambda (syntmp-x-854 syntmp-w-855) (cond ((and (null? (syntmp-wrap-marks-105 syntmp-w-855)) (null? (syntmp-wrap-subst-106 syntmp-w-855))) syntmp-x-854) ((syntmp-syntax-object?-88 syntmp-x-854) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-854) (syntmp-join-wraps-121 syntmp-w-855 (syntmp-syntax-object-wrap-90 syntmp-x-854)))) ((null? syntmp-x-854) syntmp-x-854) (else (syntmp-make-syntax-object-87 syntmp-x-854 syntmp-w-855))))) (syntmp-bound-id-member?-129 (lambda (syntmp-x-856 syntmp-list-857) (and (not (null? syntmp-list-857)) (or (syntmp-bound-id=?-126 syntmp-x-856 (car syntmp-list-857)) (syntmp-bound-id-member?-129 syntmp-x-856 (cdr syntmp-list-857)))))) (syntmp-distinct-bound-ids?-128 (lambda (syntmp-ids-858) (let syntmp-distinct?-859 ((syntmp-ids-860 syntmp-ids-858)) (or (null? syntmp-ids-860) (and (not (syntmp-bound-id-member?-129 (car syntmp-ids-860) (cdr syntmp-ids-860))) (syntmp-distinct?-859 (cdr syntmp-ids-860))))))) (syntmp-valid-bound-ids?-127 (lambda (syntmp-ids-861) (and (let syntmp-all-ids?-862 ((syntmp-ids-863 syntmp-ids-861)) (or (null? syntmp-ids-863) (and (syntmp-id?-102 (car syntmp-ids-863)) (syntmp-all-ids?-862 (cdr syntmp-ids-863))))) (syntmp-distinct-bound-ids?-128 syntmp-ids-861)))) (syntmp-bound-id=?-126 (lambda (syntmp-i-864 syntmp-j-865) (if (and (syntmp-syntax-object?-88 syntmp-i-864) (syntmp-syntax-object?-88 syntmp-j-865)) (and (eq? (let ((syntmp-e-866 (syntmp-syntax-object-expression-89 syntmp-i-864))) (if (annotation? syntmp-e-866) (annotation-expression syntmp-e-866) syntmp-e-866)) (let ((syntmp-e-867 (syntmp-syntax-object-expression-89 syntmp-j-865))) (if (annotation? syntmp-e-867) (annotation-expression syntmp-e-867) syntmp-e-867))) (syntmp-same-marks?-123 (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-i-864)) (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-j-865)))) (eq? (let ((syntmp-e-868 syntmp-i-864)) (if (annotation? syntmp-e-868) (annotation-expression syntmp-e-868) syntmp-e-868)) (let ((syntmp-e-869 syntmp-j-865)) (if (annotation? syntmp-e-869) (annotation-expression syntmp-e-869) syntmp-e-869)))))) (syntmp-free-id=?-125 (lambda (syntmp-i-870 syntmp-j-871) (and (eq? (let ((syntmp-x-872 syntmp-i-870)) (let ((syntmp-e-873 (if (syntmp-syntax-object?-88 syntmp-x-872) (syntmp-syntax-object-expression-89 syntmp-x-872) syntmp-x-872))) (if (annotation? syntmp-e-873) (annotation-expression syntmp-e-873) syntmp-e-873))) (let ((syntmp-x-874 syntmp-j-871)) (let ((syntmp-e-875 (if (syntmp-syntax-object?-88 syntmp-x-874) (syntmp-syntax-object-expression-89 syntmp-x-874) syntmp-x-874))) (if (annotation? syntmp-e-875) (annotation-expression syntmp-e-875) syntmp-e-875)))) (eq? (syntmp-id-var-name-124 syntmp-i-870 (quote (()))) (syntmp-id-var-name-124 syntmp-j-871 (quote (()))))))) (syntmp-id-var-name-124 (lambda (syntmp-id-876 syntmp-w-877) (letrec ((syntmp-search-vector-rib-880 (lambda (syntmp-sym-891 syntmp-subst-892 syntmp-marks-893 syntmp-symnames-894 syntmp-ribcage-895) (let ((syntmp-n-896 (vector-length syntmp-symnames-894))) (let syntmp-f-897 ((syntmp-i-898 0)) (cond ((syntmp-fx=-74 syntmp-i-898 syntmp-n-896) (syntmp-search-878 syntmp-sym-891 (cdr syntmp-subst-892) syntmp-marks-893)) ((and (eq? (vector-ref syntmp-symnames-894 syntmp-i-898) syntmp-sym-891) (syntmp-same-marks?-123 syntmp-marks-893 (vector-ref (syntmp-ribcage-marks-112 syntmp-ribcage-895) syntmp-i-898))) (values (vector-ref (syntmp-ribcage-labels-113 syntmp-ribcage-895) syntmp-i-898) syntmp-marks-893)) (else (syntmp-f-897 (syntmp-fx+-72 syntmp-i-898 1)))))))) (syntmp-search-list-rib-879 (lambda (syntmp-sym-899 syntmp-subst-900 syntmp-marks-901 syntmp-symnames-902 syntmp-ribcage-903) (let syntmp-f-904 ((syntmp-symnames-905 syntmp-symnames-902) (syntmp-i-906 0)) (cond ((null? syntmp-symnames-905) (syntmp-search-878 syntmp-sym-899 (cdr syntmp-subst-900) syntmp-marks-901)) ((and (eq? (car syntmp-symnames-905) syntmp-sym-899) (syntmp-same-marks?-123 syntmp-marks-901 (list-ref (syntmp-ribcage-marks-112 syntmp-ribcage-903) syntmp-i-906))) (values (list-ref (syntmp-ribcage-labels-113 syntmp-ribcage-903) syntmp-i-906) syntmp-marks-901)) (else (syntmp-f-904 (cdr syntmp-symnames-905) (syntmp-fx+-72 syntmp-i-906 1))))))) (syntmp-search-878 (lambda (syntmp-sym-907 syntmp-subst-908 syntmp-marks-909) (if (null? syntmp-subst-908) (values #f syntmp-marks-909) (let ((syntmp-fst-910 (car syntmp-subst-908))) (if (eq? syntmp-fst-910 (quote shift)) (syntmp-search-878 syntmp-sym-907 (cdr syntmp-subst-908) (cdr syntmp-marks-909)) (let ((syntmp-symnames-911 (syntmp-ribcage-symnames-111 syntmp-fst-910))) (if (vector? syntmp-symnames-911) (syntmp-search-vector-rib-880 syntmp-sym-907 syntmp-subst-908 syntmp-marks-909 syntmp-symnames-911 syntmp-fst-910) (syntmp-search-list-rib-879 syntmp-sym-907 syntmp-subst-908 syntmp-marks-909 syntmp-symnames-911 syntmp-fst-910))))))))) (cond ((symbol? syntmp-id-876) (or (call-with-values (lambda () (syntmp-search-878 syntmp-id-876 (syntmp-wrap-subst-106 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w-877))) (lambda (syntmp-x-913 . syntmp-ignore-912) syntmp-x-913)) syntmp-id-876)) ((syntmp-syntax-object?-88 syntmp-id-876) (let ((syntmp-id-914 (let ((syntmp-e-916 (syntmp-syntax-object-expression-89 syntmp-id-876))) (if (annotation? syntmp-e-916) (annotation-expression syntmp-e-916) syntmp-e-916))) (syntmp-w1-915 (syntmp-syntax-object-wrap-90 syntmp-id-876))) (let ((syntmp-marks-917 (syntmp-join-marks-122 (syntmp-wrap-marks-105 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w1-915)))) (call-with-values (lambda () (syntmp-search-878 syntmp-id-914 (syntmp-wrap-subst-106 syntmp-w-877) syntmp-marks-917)) (lambda (syntmp-new-id-918 syntmp-marks-919) (or syntmp-new-id-918 (call-with-values (lambda () (syntmp-search-878 syntmp-id-914 (syntmp-wrap-subst-106 syntmp-w1-915) syntmp-marks-919)) (lambda (syntmp-x-921 . syntmp-ignore-920) syntmp-x-921)) syntmp-id-914)))))) ((annotation? syntmp-id-876) (let ((syntmp-id-922 (let ((syntmp-e-923 syntmp-id-876)) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)))) (or (call-with-values (lambda () (syntmp-search-878 syntmp-id-922 (syntmp-wrap-subst-106 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w-877))) (lambda (syntmp-x-925 . syntmp-ignore-924) syntmp-x-925)) syntmp-id-922))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-876)))))) (syntmp-same-marks?-123 (lambda (syntmp-x-926 syntmp-y-927) (or (eq? syntmp-x-926 syntmp-y-927) (and (not (null? syntmp-x-926)) (not (null? syntmp-y-927)) (eq? (car syntmp-x-926) (car syntmp-y-927)) (syntmp-same-marks?-123 (cdr syntmp-x-926) (cdr syntmp-y-927)))))) (syntmp-join-marks-122 (lambda (syntmp-m1-928 syntmp-m2-929) (syntmp-smart-append-120 syntmp-m1-928 syntmp-m2-929))) (syntmp-join-wraps-121 (lambda (syntmp-w1-930 syntmp-w2-931) (let ((syntmp-m1-932 (syntmp-wrap-marks-105 syntmp-w1-930)) (syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w1-930))) (if (null? syntmp-m1-932) (if (null? syntmp-s1-933) syntmp-w2-931 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w2-931) (syntmp-smart-append-120 syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w2-931)))) (syntmp-make-wrap-104 (syntmp-smart-append-120 syntmp-m1-932 (syntmp-wrap-marks-105 syntmp-w2-931)) (syntmp-smart-append-120 syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w2-931))))))) (syntmp-smart-append-120 (lambda (syntmp-m1-934 syntmp-m2-935) (if (null? syntmp-m2-935) syntmp-m1-934 (append syntmp-m1-934 syntmp-m2-935)))) (syntmp-make-binding-wrap-119 (lambda (syntmp-ids-936 syntmp-labels-937 syntmp-w-938) (if (null? syntmp-ids-936) syntmp-w-938 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w-938) (cons (let ((syntmp-labelvec-939 (list->vector syntmp-labels-937))) (let ((syntmp-n-940 (vector-length syntmp-labelvec-939))) (let ((syntmp-symnamevec-941 (make-vector syntmp-n-940)) (syntmp-marksvec-942 (make-vector syntmp-n-940))) (begin (let syntmp-f-943 ((syntmp-ids-944 syntmp-ids-936) (syntmp-i-945 0)) (if (not (null? syntmp-ids-944)) (call-with-values (lambda () (syntmp-id-sym-name&marks-103 (car syntmp-ids-944) syntmp-w-938)) (lambda (syntmp-symname-946 syntmp-marks-947) (begin (vector-set! syntmp-symnamevec-941 syntmp-i-945 syntmp-symname-946) (vector-set! syntmp-marksvec-942 syntmp-i-945 syntmp-marks-947) (syntmp-f-943 (cdr syntmp-ids-944) (syntmp-fx+-72 syntmp-i-945 1))))))) (syntmp-make-ribcage-109 syntmp-symnamevec-941 syntmp-marksvec-942 syntmp-labelvec-939))))) (syntmp-wrap-subst-106 syntmp-w-938)))))) (syntmp-extend-ribcage!-118 (lambda (syntmp-ribcage-948 syntmp-id-949 syntmp-label-950) (begin (syntmp-set-ribcage-symnames!-114 syntmp-ribcage-948 (cons (let ((syntmp-e-951 (syntmp-syntax-object-expression-89 syntmp-id-949))) (if (annotation? syntmp-e-951) (annotation-expression syntmp-e-951) syntmp-e-951)) (syntmp-ribcage-symnames-111 syntmp-ribcage-948))) (syntmp-set-ribcage-marks!-115 syntmp-ribcage-948 (cons (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-id-949)) (syntmp-ribcage-marks-112 syntmp-ribcage-948))) (syntmp-set-ribcage-labels!-116 syntmp-ribcage-948 (cons syntmp-label-950 (syntmp-ribcage-labels-113 syntmp-ribcage-948)))))) (syntmp-anti-mark-117 (lambda (syntmp-w-952) (syntmp-make-wrap-104 (cons #f (syntmp-wrap-marks-105 syntmp-w-952)) (cons (quote shift) (syntmp-wrap-subst-106 syntmp-w-952))))) (syntmp-set-ribcage-labels!-116 (lambda (syntmp-x-953 syntmp-update-954) (vector-set! syntmp-x-953 3 syntmp-update-954))) (syntmp-set-ribcage-marks!-115 (lambda (syntmp-x-955 syntmp-update-956) (vector-set! syntmp-x-955 2 syntmp-update-956))) (syntmp-set-ribcage-symnames!-114 (lambda (syntmp-x-957 syntmp-update-958) (vector-set! syntmp-x-957 1 syntmp-update-958))) (syntmp-ribcage-labels-113 (lambda (syntmp-x-959) (vector-ref syntmp-x-959 3))) (syntmp-ribcage-marks-112 (lambda (syntmp-x-960) (vector-ref syntmp-x-960 2))) (syntmp-ribcage-symnames-111 (lambda (syntmp-x-961) (vector-ref syntmp-x-961 1))) (syntmp-ribcage?-110 (lambda (syntmp-x-962) (and (vector? syntmp-x-962) (= (vector-length syntmp-x-962) 4) (eq? (vector-ref syntmp-x-962 0) (quote ribcage))))) (syntmp-make-ribcage-109 (lambda (syntmp-symnames-963 syntmp-marks-964 syntmp-labels-965) (vector (quote ribcage) syntmp-symnames-963 syntmp-marks-964 syntmp-labels-965))) (syntmp-gen-labels-108 (lambda (syntmp-ls-966) (if (null? syntmp-ls-966) (quote ()) (cons (syntmp-gen-label-107) (syntmp-gen-labels-108 (cdr syntmp-ls-966)))))) (syntmp-gen-label-107 (lambda () (string #\i))) (syntmp-wrap-subst-106 cdr) (syntmp-wrap-marks-105 car) (syntmp-make-wrap-104 cons) (syntmp-id-sym-name&marks-103 (lambda (syntmp-x-967 syntmp-w-968) (if (syntmp-syntax-object?-88 syntmp-x-967) (values (let ((syntmp-e-969 (syntmp-syntax-object-expression-89 syntmp-x-967))) (if (annotation? syntmp-e-969) (annotation-expression syntmp-e-969) syntmp-e-969)) (syntmp-join-marks-122 (syntmp-wrap-marks-105 syntmp-w-968) (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-x-967)))) (values (let ((syntmp-e-970 syntmp-x-967)) (if (annotation? syntmp-e-970) (annotation-expression syntmp-e-970) syntmp-e-970)) (syntmp-wrap-marks-105 syntmp-w-968))))) (syntmp-id?-102 (lambda (syntmp-x-971) (cond ((symbol? syntmp-x-971) #t) ((syntmp-syntax-object?-88 syntmp-x-971) (symbol? (let ((syntmp-e-972 (syntmp-syntax-object-expression-89 syntmp-x-971))) (if (annotation? syntmp-e-972) (annotation-expression syntmp-e-972) syntmp-e-972)))) ((annotation? syntmp-x-971) (symbol? (annotation-expression syntmp-x-971))) (else #f)))) (syntmp-nonsymbol-id?-101 (lambda (syntmp-x-973) (and (syntmp-syntax-object?-88 syntmp-x-973) (symbol? (let ((syntmp-e-974 (syntmp-syntax-object-expression-89 syntmp-x-973))) (if (annotation? syntmp-e-974) (annotation-expression syntmp-e-974) syntmp-e-974)))))) (syntmp-global-extend-100 (lambda (syntmp-type-975 syntmp-sym-976 syntmp-val-977) (syntmp-put-global-definition-hook-79 syntmp-sym-976 (cons syntmp-type-975 syntmp-val-977)))) (syntmp-lookup-99 (lambda (syntmp-x-978 syntmp-r-979) (cond ((assq syntmp-x-978 syntmp-r-979) => cdr) ((symbol? syntmp-x-978) (or (syntmp-get-global-definition-hook-80 syntmp-x-978) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-98 (lambda (syntmp-r-980) (if (null? syntmp-r-980) (quote ()) (let ((syntmp-a-981 (car syntmp-r-980))) (if (eq? (cadr syntmp-a-981) (quote macro)) (cons syntmp-a-981 (syntmp-macros-only-env-98 (cdr syntmp-r-980))) (syntmp-macros-only-env-98 (cdr syntmp-r-980))))))) (syntmp-extend-var-env-97 (lambda (syntmp-labels-982 syntmp-vars-983 syntmp-r-984) (if (null? syntmp-labels-982) syntmp-r-984 (syntmp-extend-var-env-97 (cdr syntmp-labels-982) (cdr syntmp-vars-983) (cons (cons (car syntmp-labels-982) (cons (quote lexical) (car syntmp-vars-983))) syntmp-r-984))))) (syntmp-extend-env-96 (lambda (syntmp-labels-985 syntmp-bindings-986 syntmp-r-987) (if (null? syntmp-labels-985) syntmp-r-987 (syntmp-extend-env-96 (cdr syntmp-labels-985) (cdr syntmp-bindings-986) (cons (cons (car syntmp-labels-985) (car syntmp-bindings-986)) syntmp-r-987))))) (syntmp-binding-value-95 cdr) (syntmp-binding-type-94 car) (syntmp-source-annotation-93 (lambda (syntmp-x-988) (cond ((annotation? syntmp-x-988) (annotation-source syntmp-x-988)) ((syntmp-syntax-object?-88 syntmp-x-988) (syntmp-source-annotation-93 (syntmp-syntax-object-expression-89 syntmp-x-988))) (else #f)))) (syntmp-set-syntax-object-wrap!-92 (lambda (syntmp-x-989 syntmp-update-990) (vector-set! syntmp-x-989 2 syntmp-update-990))) (syntmp-set-syntax-object-expression!-91 (lambda (syntmp-x-991 syntmp-update-992) (vector-set! syntmp-x-991 1 syntmp-update-992))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-993) (vector-ref syntmp-x-993 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-994) (vector-ref syntmp-x-994 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (= (vector-length syntmp-x-995) 3) (eq? (vector-ref syntmp-x-995 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-996 syntmp-wrap-997) (vector (quote syntax-object) syntmp-expression-996 syntmp-wrap-997))) (syntmp-build-letrec-86 (lambda (syntmp-src-998 syntmp-vars-999 syntmp-val-exps-1000 syntmp-body-exp-1001) (if (null? syntmp-vars-999) (syntmp-build-annotated-81 syntmp-src-998 syntmp-body-exp-1001) (syntmp-build-annotated-81 syntmp-src-998 (list (quote letrec) (map list syntmp-vars-999 syntmp-val-exps-1000) syntmp-body-exp-1001))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1002 syntmp-vars-1003 syntmp-val-exps-1004 syntmp-body-exp-1005) (if (null? syntmp-vars-1003) (syntmp-build-annotated-81 syntmp-src-1002 syntmp-body-exp-1005) (syntmp-build-annotated-81 syntmp-src-1002 (list (quote let) (car syntmp-vars-1003) (map list (cdr syntmp-vars-1003) syntmp-val-exps-1004) syntmp-body-exp-1005))))) (syntmp-build-let-84 (lambda (syntmp-src-1006 syntmp-vars-1007 syntmp-val-exps-1008 syntmp-body-exp-1009) (if (null? syntmp-vars-1007) (syntmp-build-annotated-81 syntmp-src-1006 syntmp-body-exp-1009) (syntmp-build-annotated-81 syntmp-src-1006 (list (quote let) (map list syntmp-vars-1007 syntmp-val-exps-1008) syntmp-body-exp-1009))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1010 syntmp-exps-1011) (if (null? (cdr syntmp-exps-1011)) (syntmp-build-annotated-81 syntmp-src-1010 (car syntmp-exps-1011)) (syntmp-build-annotated-81 syntmp-src-1010 (cons (quote begin) syntmp-exps-1011))))) (syntmp-build-data-82 (lambda (syntmp-src-1012 syntmp-exp-1013) (if (and (self-evaluating? syntmp-exp-1013) (not (vector? syntmp-exp-1013))) (syntmp-build-annotated-81 syntmp-src-1012 syntmp-exp-1013) (syntmp-build-annotated-81 syntmp-src-1012 (list (quote quote) syntmp-exp-1013))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1014 syntmp-exp-1015) (if (and syntmp-src-1014 (not (annotation? syntmp-exp-1015))) (make-annotation syntmp-exp-1015 syntmp-src-1014 #t) syntmp-exp-1015))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1016) (getprop syntmp-symbol-1016 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1017 syntmp-binding-1018) (putprop syntmp-symbol-1017 (quote *sc-expander*) syntmp-binding-1018))) (syntmp-error-hook-78 (lambda (syntmp-who-1019 syntmp-why-1020 syntmp-what-1021) (error syntmp-who-1019 "~a ~s" syntmp-why-1020 syntmp-what-1021))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1022) (eval (list syntmp-noexpand-71 syntmp-x-1022) (interaction-environment)))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1023) (eval (list syntmp-noexpand-71 syntmp-x-1023) (interaction-environment)))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-100 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-100 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-100 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1024 syntmp-r-1025 syntmp-w-1026 syntmp-s-1027) ((lambda (syntmp-tmp-1028) ((lambda (syntmp-tmp-1029) (if (if syntmp-tmp-1029 (apply (lambda (syntmp-_-1030 syntmp-var-1031 syntmp-val-1032 syntmp-e1-1033 syntmp-e2-1034) (syntmp-valid-bound-ids?-127 syntmp-var-1031)) syntmp-tmp-1029) #f) (apply (lambda (syntmp-_-1036 syntmp-var-1037 syntmp-val-1038 syntmp-e1-1039 syntmp-e2-1040) (let ((syntmp-names-1041 (map (lambda (syntmp-x-1042) (syntmp-id-var-name-124 syntmp-x-1042 syntmp-w-1026)) syntmp-var-1037))) (begin (for-each (lambda (syntmp-id-1044 syntmp-n-1045) (let ((syntmp-t-1046 (syntmp-binding-type-94 (syntmp-lookup-99 syntmp-n-1045 syntmp-r-1025)))) (if (memv syntmp-t-1046 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-131 syntmp-id-1044 syntmp-w-1026 syntmp-s-1027) "identifier out of context")))) syntmp-var-1037 syntmp-names-1041) (syntmp-chi-body-142 (cons syntmp-e1-1039 syntmp-e2-1040) (syntmp-source-wrap-131 syntmp-e-1024 syntmp-w-1026 syntmp-s-1027) (syntmp-extend-env-96 syntmp-names-1041 (let ((syntmp-trans-r-1049 (syntmp-macros-only-env-98 syntmp-r-1025))) (map (lambda (syntmp-x-1050) (cons (quote macro) (syntmp-eval-local-transformer-145 (syntmp-chi-138 syntmp-x-1050 syntmp-trans-r-1049 syntmp-w-1026)))) syntmp-val-1038)) syntmp-r-1025) syntmp-w-1026)))) syntmp-tmp-1029) ((lambda (syntmp-_-1052) (syntax-error (syntmp-source-wrap-131 syntmp-e-1024 syntmp-w-1026 syntmp-s-1027))) syntmp-tmp-1028))) (syntax-dispatch syntmp-tmp-1028 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1024))) (syntmp-global-extend-100 (quote core) (quote quote) (lambda (syntmp-e-1053 syntmp-r-1054 syntmp-w-1055 syntmp-s-1056) ((lambda (syntmp-tmp-1057) ((lambda (syntmp-tmp-1058) (if syntmp-tmp-1058 (apply (lambda (syntmp-_-1059 syntmp-e-1060) (syntmp-build-data-82 syntmp-s-1056 (syntmp-strip-149 syntmp-e-1060 syntmp-w-1055))) syntmp-tmp-1058) ((lambda (syntmp-_-1061) (syntax-error (syntmp-source-wrap-131 syntmp-e-1053 syntmp-w-1055 syntmp-s-1056))) syntmp-tmp-1057))) (syntax-dispatch syntmp-tmp-1057 (quote (any any))))) syntmp-e-1053))) (syntmp-global-extend-100 (quote core) (quote syntax) (letrec ((syntmp-regen-1069 (lambda (syntmp-x-1070) (let ((syntmp-t-1071 (car syntmp-x-1070))) (if (memv syntmp-t-1071 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1070) (syntmp-regen-1069 (caddr syntmp-x-1070)))) (if (memv syntmp-t-1071 (quote (map))) (let ((syntmp-ls-1072 (map syntmp-regen-1069 (cdr syntmp-x-1070)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1072) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1072))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1070)) (map syntmp-regen-1069 (cdr syntmp-x-1070)))))))))))) (syntmp-gen-vector-1068 (lambda (syntmp-x-1073) (cond ((eq? (car syntmp-x-1073) (quote list)) (cons (quote vector) (cdr syntmp-x-1073))) ((eq? (car syntmp-x-1073) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1073)))) (else (list (quote list->vector) syntmp-x-1073))))) (syntmp-gen-append-1067 (lambda (syntmp-x-1074 syntmp-y-1075) (if (equal? syntmp-y-1075 (quote (quote ()))) syntmp-x-1074 (list (quote append) syntmp-x-1074 syntmp-y-1075)))) (syntmp-gen-cons-1066 (lambda (syntmp-x-1076 syntmp-y-1077) (let ((syntmp-t-1078 (car syntmp-y-1077))) (if (memv syntmp-t-1078 (quote (quote))) (if (eq? (car syntmp-x-1076) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1076) (cadr syntmp-y-1077))) (if (eq? (cadr syntmp-y-1077) (quote ())) (list (quote list) syntmp-x-1076) (list (quote cons) syntmp-x-1076 syntmp-y-1077))) (if (memv syntmp-t-1078 (quote (list))) (cons (quote list) (cons syntmp-x-1076 (cdr syntmp-y-1077))) (list (quote cons) syntmp-x-1076 syntmp-y-1077)))))) (syntmp-gen-map-1065 (lambda (syntmp-e-1079 syntmp-map-env-1080) (let ((syntmp-formals-1081 (map cdr syntmp-map-env-1080)) (syntmp-actuals-1082 (map (lambda (syntmp-x-1083) (list (quote ref) (car syntmp-x-1083))) syntmp-map-env-1080))) (cond ((eq? (car syntmp-e-1079) (quote ref)) (car syntmp-actuals-1082)) ((andmap (lambda (syntmp-x-1084) (and (eq? (car syntmp-x-1084) (quote ref)) (memq (cadr syntmp-x-1084) syntmp-formals-1081))) (cdr syntmp-e-1079)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1079)) (map (let ((syntmp-r-1085 (map cons syntmp-formals-1081 syntmp-actuals-1082))) (lambda (syntmp-x-1086) (cdr (assq (cadr syntmp-x-1086) syntmp-r-1085)))) (cdr syntmp-e-1079))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1081 syntmp-e-1079) syntmp-actuals-1082))))))) (syntmp-gen-mappend-1064 (lambda (syntmp-e-1087 syntmp-map-env-1088) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1065 syntmp-e-1087 syntmp-map-env-1088)))) (syntmp-gen-ref-1063 (lambda (syntmp-src-1089 syntmp-var-1090 syntmp-level-1091 syntmp-maps-1092) (if (syntmp-fx=-74 syntmp-level-1091 0) (values syntmp-var-1090 syntmp-maps-1092) (if (null? syntmp-maps-1092) (syntax-error syntmp-src-1089 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1063 syntmp-src-1089 syntmp-var-1090 (syntmp-fx--73 syntmp-level-1091 1) (cdr syntmp-maps-1092))) (lambda (syntmp-outer-var-1093 syntmp-outer-maps-1094) (let ((syntmp-b-1095 (assq syntmp-outer-var-1093 (car syntmp-maps-1092)))) (if syntmp-b-1095 (values (cdr syntmp-b-1095) syntmp-maps-1092) (let ((syntmp-inner-var-1096 (syntmp-gen-var-150 (quote tmp)))) (values syntmp-inner-var-1096 (cons (cons (cons syntmp-outer-var-1093 syntmp-inner-var-1096) (car syntmp-maps-1092)) syntmp-outer-maps-1094))))))))))) (syntmp-gen-syntax-1062 (lambda (syntmp-src-1097 syntmp-e-1098 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101) (if (syntmp-id?-102 syntmp-e-1098) (let ((syntmp-label-1102 (syntmp-id-var-name-124 syntmp-e-1098 (quote (()))))) (let ((syntmp-b-1103 (syntmp-lookup-99 syntmp-label-1102 syntmp-r-1099))) (if (eq? (syntmp-binding-type-94 syntmp-b-1103) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1104 (syntmp-binding-value-95 syntmp-b-1103))) (syntmp-gen-ref-1063 syntmp-src-1097 (car syntmp-var.lev-1104) (cdr syntmp-var.lev-1104) syntmp-maps-1100))) (lambda (syntmp-var-1105 syntmp-maps-1106) (values (list (quote ref) syntmp-var-1105) syntmp-maps-1106))) (if (syntmp-ellipsis?-1101 syntmp-e-1098) (syntax-error syntmp-src-1097 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1098) syntmp-maps-1100))))) ((lambda (syntmp-tmp-1107) ((lambda (syntmp-tmp-1108) (if (if syntmp-tmp-1108 (apply (lambda (syntmp-dots-1109 syntmp-e-1110) (syntmp-ellipsis?-1101 syntmp-dots-1109)) syntmp-tmp-1108) #f) (apply (lambda (syntmp-dots-1111 syntmp-e-1112) (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-e-1112 syntmp-r-1099 syntmp-maps-1100 (lambda (syntmp-x-1113) #f))) syntmp-tmp-1108) ((lambda (syntmp-tmp-1114) (if (if syntmp-tmp-1114 (apply (lambda (syntmp-x-1115 syntmp-dots-1116 syntmp-y-1117) (syntmp-ellipsis?-1101 syntmp-dots-1116)) syntmp-tmp-1114) #f) (apply (lambda (syntmp-x-1118 syntmp-dots-1119 syntmp-y-1120) (let syntmp-f-1121 ((syntmp-y-1122 syntmp-y-1120) (syntmp-k-1123 (lambda (syntmp-maps-1124) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-x-1118 syntmp-r-1099 (cons (quote ()) syntmp-maps-1124) syntmp-ellipsis?-1101)) (lambda (syntmp-x-1125 syntmp-maps-1126) (if (null? (car syntmp-maps-1126)) (syntax-error syntmp-src-1097 "extra ellipsis in syntax form") (values (syntmp-gen-map-1065 syntmp-x-1125 (car syntmp-maps-1126)) (cdr syntmp-maps-1126)))))))) ((lambda (syntmp-tmp-1127) ((lambda (syntmp-tmp-1128) (if (if syntmp-tmp-1128 (apply (lambda (syntmp-dots-1129 syntmp-y-1130) (syntmp-ellipsis?-1101 syntmp-dots-1129)) syntmp-tmp-1128) #f) (apply (lambda (syntmp-dots-1131 syntmp-y-1132) (syntmp-f-1121 syntmp-y-1132 (lambda (syntmp-maps-1133) (call-with-values (lambda () (syntmp-k-1123 (cons (quote ()) syntmp-maps-1133))) (lambda (syntmp-x-1134 syntmp-maps-1135) (if (null? (car syntmp-maps-1135)) (syntax-error syntmp-src-1097 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1064 syntmp-x-1134 (car syntmp-maps-1135)) (cdr syntmp-maps-1135)))))))) syntmp-tmp-1128) ((lambda (syntmp-_-1136) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-y-1122 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-y-1137 syntmp-maps-1138) (call-with-values (lambda () (syntmp-k-1123 syntmp-maps-1138)) (lambda (syntmp-x-1139 syntmp-maps-1140) (values (syntmp-gen-append-1067 syntmp-x-1139 syntmp-y-1137) syntmp-maps-1140)))))) syntmp-tmp-1127))) (syntax-dispatch syntmp-tmp-1127 (quote (any . any))))) syntmp-y-1122))) syntmp-tmp-1114) ((lambda (syntmp-tmp-1141) (if syntmp-tmp-1141 (apply (lambda (syntmp-x-1142 syntmp-y-1143) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-x-1142 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-x-1144 syntmp-maps-1145) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-y-1143 syntmp-r-1099 syntmp-maps-1145 syntmp-ellipsis?-1101)) (lambda (syntmp-y-1146 syntmp-maps-1147) (values (syntmp-gen-cons-1066 syntmp-x-1144 syntmp-y-1146) syntmp-maps-1147)))))) syntmp-tmp-1141) ((lambda (syntmp-tmp-1148) (if syntmp-tmp-1148 (apply (lambda (syntmp-e1-1149 syntmp-e2-1150) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 (cons syntmp-e1-1149 syntmp-e2-1150) syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-e-1152 syntmp-maps-1153) (values (syntmp-gen-vector-1068 syntmp-e-1152) syntmp-maps-1153)))) syntmp-tmp-1148) ((lambda (syntmp-_-1154) (values (list (quote quote) syntmp-e-1098) syntmp-maps-1100)) syntmp-tmp-1107))) (syntax-dispatch syntmp-tmp-1107 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1107 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1107 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1107 (quote (any any))))) syntmp-e-1098))))) (lambda (syntmp-e-1155 syntmp-r-1156 syntmp-w-1157 syntmp-s-1158) (let ((syntmp-e-1159 (syntmp-source-wrap-131 syntmp-e-1155 syntmp-w-1157 syntmp-s-1158))) ((lambda (syntmp-tmp-1160) ((lambda (syntmp-tmp-1161) (if syntmp-tmp-1161 (apply (lambda (syntmp-_-1162 syntmp-x-1163) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-e-1159 syntmp-x-1163 syntmp-r-1156 (quote ()) syntmp-ellipsis?-147)) (lambda (syntmp-e-1164 syntmp-maps-1165) (syntmp-regen-1069 syntmp-e-1164)))) syntmp-tmp-1161) ((lambda (syntmp-_-1166) (syntax-error syntmp-e-1159)) syntmp-tmp-1160))) (syntax-dispatch syntmp-tmp-1160 (quote (any any))))) syntmp-e-1159))))) (syntmp-global-extend-100 (quote core) (quote lambda) (lambda (syntmp-e-1167 syntmp-r-1168 syntmp-w-1169 syntmp-s-1170) ((lambda (syntmp-tmp-1171) ((lambda (syntmp-tmp-1172) (if syntmp-tmp-1172 (apply (lambda (syntmp-_-1173 syntmp-c-1174) (syntmp-chi-lambda-clause-143 (syntmp-source-wrap-131 syntmp-e-1167 syntmp-w-1169 syntmp-s-1170) syntmp-c-1174 syntmp-r-1168 syntmp-w-1169 (lambda (syntmp-vars-1175 syntmp-body-1176) (syntmp-build-annotated-81 syntmp-s-1170 (list (quote lambda) syntmp-vars-1175 syntmp-body-1176))))) syntmp-tmp-1172) (syntax-error syntmp-tmp-1171))) (syntax-dispatch syntmp-tmp-1171 (quote (any . any))))) syntmp-e-1167))) (syntmp-global-extend-100 (quote core) (quote let) (letrec ((syntmp-chi-let-1177 (lambda (syntmp-e-1178 syntmp-r-1179 syntmp-w-1180 syntmp-s-1181 syntmp-constructor-1182 syntmp-ids-1183 syntmp-vals-1184 syntmp-exps-1185) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-1183)) (syntax-error syntmp-e-1178 "duplicate bound variable in") (let ((syntmp-labels-1186 (syntmp-gen-labels-108 syntmp-ids-1183)) (syntmp-new-vars-1187 (map syntmp-gen-var-150 syntmp-ids-1183))) (let ((syntmp-nw-1188 (syntmp-make-binding-wrap-119 syntmp-ids-1183 syntmp-labels-1186 syntmp-w-1180)) (syntmp-nr-1189 (syntmp-extend-var-env-97 syntmp-labels-1186 syntmp-new-vars-1187 syntmp-r-1179))) (syntmp-constructor-1182 syntmp-s-1181 syntmp-new-vars-1187 (map (lambda (syntmp-x-1190) (syntmp-chi-138 syntmp-x-1190 syntmp-r-1179 syntmp-w-1180)) syntmp-vals-1184) (syntmp-chi-body-142 syntmp-exps-1185 (syntmp-source-wrap-131 syntmp-e-1178 syntmp-nw-1188 syntmp-s-1181) syntmp-nr-1189 syntmp-nw-1188)))))))) (lambda (syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194) ((lambda (syntmp-tmp-1195) ((lambda (syntmp-tmp-1196) (if syntmp-tmp-1196 (apply (lambda (syntmp-_-1197 syntmp-id-1198 syntmp-val-1199 syntmp-e1-1200 syntmp-e2-1201) (syntmp-chi-let-1177 syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194 syntmp-build-let-84 syntmp-id-1198 syntmp-val-1199 (cons syntmp-e1-1200 syntmp-e2-1201))) syntmp-tmp-1196) ((lambda (syntmp-tmp-1205) (if (if syntmp-tmp-1205 (apply (lambda (syntmp-_-1206 syntmp-f-1207 syntmp-id-1208 syntmp-val-1209 syntmp-e1-1210 syntmp-e2-1211) (syntmp-id?-102 syntmp-f-1207)) syntmp-tmp-1205) #f) (apply (lambda (syntmp-_-1212 syntmp-f-1213 syntmp-id-1214 syntmp-val-1215 syntmp-e1-1216 syntmp-e2-1217) (syntmp-chi-let-1177 syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194 syntmp-build-named-let-85 (cons syntmp-f-1213 syntmp-id-1214) syntmp-val-1215 (cons syntmp-e1-1216 syntmp-e2-1217))) syntmp-tmp-1205) ((lambda (syntmp-_-1221) (syntax-error (syntmp-source-wrap-131 syntmp-e-1191 syntmp-w-1193 syntmp-s-1194))) syntmp-tmp-1195))) (syntax-dispatch syntmp-tmp-1195 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1195 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1191)))) (syntmp-global-extend-100 (quote core) (quote letrec) (lambda (syntmp-e-1222 syntmp-r-1223 syntmp-w-1224 syntmp-s-1225) ((lambda (syntmp-tmp-1226) ((lambda (syntmp-tmp-1227) (if syntmp-tmp-1227 (apply (lambda (syntmp-_-1228 syntmp-id-1229 syntmp-val-1230 syntmp-e1-1231 syntmp-e2-1232) (let ((syntmp-ids-1233 syntmp-id-1229)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-1233)) (syntax-error syntmp-e-1222 "duplicate bound variable in") (let ((syntmp-labels-1235 (syntmp-gen-labels-108 syntmp-ids-1233)) (syntmp-new-vars-1236 (map syntmp-gen-var-150 syntmp-ids-1233))) (let ((syntmp-w-1237 (syntmp-make-binding-wrap-119 syntmp-ids-1233 syntmp-labels-1235 syntmp-w-1224)) (syntmp-r-1238 (syntmp-extend-var-env-97 syntmp-labels-1235 syntmp-new-vars-1236 syntmp-r-1223))) (syntmp-build-letrec-86 syntmp-s-1225 syntmp-new-vars-1236 (map (lambda (syntmp-x-1239) (syntmp-chi-138 syntmp-x-1239 syntmp-r-1238 syntmp-w-1237)) syntmp-val-1230) (syntmp-chi-body-142 (cons syntmp-e1-1231 syntmp-e2-1232) (syntmp-source-wrap-131 syntmp-e-1222 syntmp-w-1237 syntmp-s-1225) syntmp-r-1238 syntmp-w-1237))))))) syntmp-tmp-1227) ((lambda (syntmp-_-1242) (syntax-error (syntmp-source-wrap-131 syntmp-e-1222 syntmp-w-1224 syntmp-s-1225))) syntmp-tmp-1226))) (syntax-dispatch syntmp-tmp-1226 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1222))) (syntmp-global-extend-100 (quote core) (quote set!) (lambda (syntmp-e-1243 syntmp-r-1244 syntmp-w-1245 syntmp-s-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-id-1250 syntmp-val-1251) (syntmp-id?-102 syntmp-id-1250)) syntmp-tmp-1248) #f) (apply (lambda (syntmp-_-1252 syntmp-id-1253 syntmp-val-1254) (let ((syntmp-val-1255 (syntmp-chi-138 syntmp-val-1254 syntmp-r-1244 syntmp-w-1245)) (syntmp-n-1256 (syntmp-id-var-name-124 syntmp-id-1253 syntmp-w-1245))) (let ((syntmp-b-1257 (syntmp-lookup-99 syntmp-n-1256 syntmp-r-1244))) (let ((syntmp-t-1258 (syntmp-binding-type-94 syntmp-b-1257))) (if (memv syntmp-t-1258 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1246 (list (quote set!) (syntmp-binding-value-95 syntmp-b-1257) syntmp-val-1255)) (if (memv syntmp-t-1258 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1246 (list (quote set!) syntmp-n-1256 syntmp-val-1255)) (if (memv syntmp-t-1258 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-130 syntmp-id-1253 syntmp-w-1245) "identifier out of context") (syntax-error (syntmp-source-wrap-131 syntmp-e-1243 syntmp-w-1245 syntmp-s-1246))))))))) syntmp-tmp-1248) ((lambda (syntmp-tmp-1259) (if syntmp-tmp-1259 (apply (lambda (syntmp-_-1260 syntmp-getter-1261 syntmp-arg-1262 syntmp-val-1263) (syntmp-build-annotated-81 syntmp-s-1246 (cons (syntmp-chi-138 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1261) syntmp-r-1244 syntmp-w-1245) (map (lambda (syntmp-e-1264) (syntmp-chi-138 syntmp-e-1264 syntmp-r-1244 syntmp-w-1245)) (append syntmp-arg-1262 (list syntmp-val-1263)))))) syntmp-tmp-1259) ((lambda (syntmp-_-1266) (syntax-error (syntmp-source-wrap-131 syntmp-e-1243 syntmp-w-1245 syntmp-s-1246))) syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1247 (quote (any any any))))) syntmp-e-1243))) (syntmp-global-extend-100 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-100 (quote define) (quote define) (quote ())) (syntmp-global-extend-100 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-100 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-100 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1270 (lambda (syntmp-x-1271 syntmp-keys-1272 syntmp-clauses-1273 syntmp-r-1274) (if (null? syntmp-clauses-1273) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1271)) ((lambda (syntmp-tmp-1275) ((lambda (syntmp-tmp-1276) (if syntmp-tmp-1276 (apply (lambda (syntmp-pat-1277 syntmp-exp-1278) (if (and (syntmp-id?-102 syntmp-pat-1277) (andmap (lambda (syntmp-x-1279) (not (syntmp-free-id=?-125 syntmp-pat-1277 syntmp-x-1279))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels 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 macros-only-env extend-var-env extend-env null-env 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 build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (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")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1272))) (let ((syntmp-labels-1280 (list (syntmp-gen-label-107))) (syntmp-var-1281 (syntmp-gen-var-150 syntmp-pat-1277))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1281) (syntmp-chi-138 syntmp-exp-1278 (syntmp-extend-env-96 syntmp-labels-1280 (list (cons (quote syntax) (cons syntmp-var-1281 0))) syntmp-r-1274) (syntmp-make-binding-wrap-119 (list syntmp-pat-1277) syntmp-labels-1280 (quote (())))))) syntmp-x-1271))) (syntmp-gen-clause-1269 syntmp-x-1271 syntmp-keys-1272 (cdr syntmp-clauses-1273) syntmp-r-1274 syntmp-pat-1277 #t syntmp-exp-1278))) syntmp-tmp-1276) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-pat-1283 syntmp-fender-1284 syntmp-exp-1285) (syntmp-gen-clause-1269 syntmp-x-1271 syntmp-keys-1272 (cdr syntmp-clauses-1273) syntmp-r-1274 syntmp-pat-1283 syntmp-fender-1284 syntmp-exp-1285)) syntmp-tmp-1282) ((lambda (syntmp-_-1286) (syntax-error (car syntmp-clauses-1273) "invalid syntax-case clause")) syntmp-tmp-1275))) (syntax-dispatch syntmp-tmp-1275 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1275 (quote (any any))))) (car syntmp-clauses-1273))))) (syntmp-gen-clause-1269 (lambda (syntmp-x-1287 syntmp-keys-1288 syntmp-clauses-1289 syntmp-r-1290 syntmp-pat-1291 syntmp-fender-1292 syntmp-exp-1293) (call-with-values (lambda () (syntmp-convert-pattern-1267 syntmp-pat-1291 syntmp-keys-1288)) (lambda (syntmp-p-1294 syntmp-pvars-1295) (cond ((not (syntmp-distinct-bound-ids?-128 (map car syntmp-pvars-1295))) (syntax-error syntmp-pat-1291 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1296) (not (syntmp-ellipsis?-147 (car syntmp-x-1296)))) syntmp-pvars-1295)) (syntax-error syntmp-pat-1291 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1297 (syntmp-gen-var-150 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1297) (let ((syntmp-y-1298 (syntmp-build-annotated-81 #f syntmp-y-1297))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1299) ((lambda (syntmp-tmp-1300) (if syntmp-tmp-1300 (apply (lambda () syntmp-y-1298) syntmp-tmp-1300) ((lambda (syntmp-_-1301) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1298 (syntmp-build-dispatch-call-1268 syntmp-pvars-1295 syntmp-fender-1292 syntmp-y-1298 syntmp-r-1290) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1299))) (syntax-dispatch syntmp-tmp-1299 (quote #(atom #t))))) syntmp-fender-1292) (syntmp-build-dispatch-call-1268 syntmp-pvars-1295 syntmp-exp-1293 syntmp-y-1298 syntmp-r-1290) (syntmp-gen-syntax-case-1270 syntmp-x-1287 syntmp-keys-1288 syntmp-clauses-1289 syntmp-r-1290)))))) (if (eq? syntmp-p-1294 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1287)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1287 (syntmp-build-data-82 #f syntmp-p-1294))))))))))))) (syntmp-build-dispatch-call-1268 (lambda (syntmp-pvars-1302 syntmp-exp-1303 syntmp-y-1304 syntmp-r-1305) (let ((syntmp-ids-1306 (map car syntmp-pvars-1302)) (syntmp-levels-1307 (map cdr syntmp-pvars-1302))) (let ((syntmp-labels-1308 (syntmp-gen-labels-108 syntmp-ids-1306)) (syntmp-new-vars-1309 (map syntmp-gen-var-150 syntmp-ids-1306))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1309 (syntmp-chi-138 syntmp-exp-1303 (syntmp-extend-env-96 syntmp-labels-1308 (map (lambda (syntmp-var-1310 syntmp-level-1311) (cons (quote syntax) (cons syntmp-var-1310 syntmp-level-1311))) syntmp-new-vars-1309 (map cdr syntmp-pvars-1302)) syntmp-r-1305) (syntmp-make-binding-wrap-119 syntmp-ids-1306 syntmp-labels-1308 (quote (())))))) syntmp-y-1304)))))) (syntmp-convert-pattern-1267 (lambda (syntmp-pattern-1312 syntmp-keys-1313) (let syntmp-cvt-1314 ((syntmp-p-1315 syntmp-pattern-1312) (syntmp-n-1316 0) (syntmp-ids-1317 (quote ()))) (if (syntmp-id?-102 syntmp-p-1315) (if (syntmp-bound-id-member?-129 syntmp-p-1315 syntmp-keys-1313) (values (vector (quote free-id) syntmp-p-1315) syntmp-ids-1317) (values (quote any) (cons (cons syntmp-p-1315 syntmp-n-1316) syntmp-ids-1317))) ((lambda (syntmp-tmp-1318) ((lambda (syntmp-tmp-1319) (if (if syntmp-tmp-1319 (apply (lambda (syntmp-x-1320 syntmp-dots-1321) (syntmp-ellipsis?-147 syntmp-dots-1321)) syntmp-tmp-1319) #f) (apply (lambda (syntmp-x-1322 syntmp-dots-1323) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1322 (syntmp-fx+-72 syntmp-n-1316 1) syntmp-ids-1317)) (lambda (syntmp-p-1324 syntmp-ids-1325) (values (if (eq? syntmp-p-1324 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1324)) syntmp-ids-1325)))) syntmp-tmp-1319) ((lambda (syntmp-tmp-1326) (if syntmp-tmp-1326 (apply (lambda (syntmp-x-1327 syntmp-y-1328) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-y-1328 syntmp-n-1316 syntmp-ids-1317)) (lambda (syntmp-y-1329 syntmp-ids-1330) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1327 syntmp-n-1316 syntmp-ids-1330)) (lambda (syntmp-x-1331 syntmp-ids-1332) (values (cons syntmp-x-1331 syntmp-y-1329) syntmp-ids-1332)))))) syntmp-tmp-1326) ((lambda (syntmp-tmp-1333) (if syntmp-tmp-1333 (apply (lambda () (values (quote ()) syntmp-ids-1317)) syntmp-tmp-1333) ((lambda (syntmp-tmp-1334) (if syntmp-tmp-1334 (apply (lambda (syntmp-x-1335) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1335 syntmp-n-1316 syntmp-ids-1317)) (lambda (syntmp-p-1337 syntmp-ids-1338) (values (vector (quote vector) syntmp-p-1337) syntmp-ids-1338)))) syntmp-tmp-1334) ((lambda (syntmp-x-1339) (values (vector (quote atom) (syntmp-strip-149 syntmp-p-1315 (quote (())))) syntmp-ids-1317)) syntmp-tmp-1318))) (syntax-dispatch syntmp-tmp-1318 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1318 (quote ()))))) (syntax-dispatch syntmp-tmp-1318 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1318 (quote (any any))))) syntmp-p-1315)))))) (lambda (syntmp-e-1340 syntmp-r-1341 syntmp-w-1342 syntmp-s-1343) (let ((syntmp-e-1344 (syntmp-source-wrap-131 syntmp-e-1340 syntmp-w-1342 syntmp-s-1343))) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if syntmp-tmp-1346 (apply (lambda (syntmp-_-1347 syntmp-val-1348 syntmp-key-1349 syntmp-m-1350) (if (andmap (lambda (syntmp-x-1351) (and (syntmp-id?-102 syntmp-x-1351) (not (syntmp-ellipsis?-147 syntmp-x-1351)))) syntmp-key-1349) (let ((syntmp-x-1353 (syntmp-gen-var-150 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1343 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1353) (syntmp-gen-syntax-case-1270 (syntmp-build-annotated-81 #f syntmp-x-1353) syntmp-key-1349 syntmp-m-1350 syntmp-r-1341))) (syntmp-chi-138 syntmp-val-1348 syntmp-r-1341 (quote (())))))) (syntax-error syntmp-e-1344 "invalid literals list in"))) syntmp-tmp-1346) (syntax-error syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any any each-any . each-any))))) syntmp-e-1344))))) (set! sc-expand (let ((syntmp-m-1356 (quote e)) (syntmp-esew-1357 (quote (eval)))) (lambda (syntmp-x-1358) (if (and (pair? syntmp-x-1358) (equal? (car syntmp-x-1358) syntmp-noexpand-71)) (cadr syntmp-x-1358) (syntmp-chi-top-137 syntmp-x-1358 (quote ()) (quote ((top))) syntmp-m-1356 syntmp-esew-1357))))) (set! sc-expand3 (let ((syntmp-m-1359 (quote e)) (syntmp-esew-1360 (quote (eval)))) (lambda (syntmp-x-1362 . syntmp-rest-1361) (if (and (pair? syntmp-x-1362) (equal? (car syntmp-x-1362) syntmp-noexpand-71)) (cadr syntmp-x-1362) (syntmp-chi-top-137 syntmp-x-1362 (quote ()) (quote ((top))) (if (null? syntmp-rest-1361) syntmp-m-1359 (car syntmp-rest-1361)) (if (or (null? syntmp-rest-1361) (null? (cdr syntmp-rest-1361))) syntmp-esew-1360 (cadr syntmp-rest-1361))))))) (set! identifier? (lambda (syntmp-x-1363) (syntmp-nonsymbol-id?-101 syntmp-x-1363))) (set! datum->syntax-object (lambda (syntmp-id-1364 syntmp-datum-1365) (syntmp-make-syntax-object-87 syntmp-datum-1365 (syntmp-syntax-object-wrap-90 syntmp-id-1364)))) (set! syntax-object->datum (lambda (syntmp-x-1366) (syntmp-strip-149 syntmp-x-1366 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1367) (begin (let ((syntmp-x-1368 syntmp-ls-1367)) (if (not (list? syntmp-x-1368)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1368))) (map (lambda (syntmp-x-1369) (syntmp-wrap-130 (gensym) (quote ((top))))) syntmp-ls-1367)))) (set! free-identifier=? (lambda (syntmp-x-1370 syntmp-y-1371) (begin (let ((syntmp-x-1372 syntmp-x-1370)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1372)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1372))) (let ((syntmp-x-1373 syntmp-y-1371)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1373)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1373))) (syntmp-free-id=?-125 syntmp-x-1370 syntmp-y-1371)))) (set! bound-identifier=? (lambda (syntmp-x-1374 syntmp-y-1375) (begin (let ((syntmp-x-1376 syntmp-x-1374)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1376)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1376))) (let ((syntmp-x-1377 syntmp-y-1375)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1377)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1377))) (syntmp-bound-id=?-126 syntmp-x-1374 syntmp-y-1375)))) (set! syntax-error (lambda (syntmp-object-1379 . syntmp-messages-1378) (begin (for-each (lambda (syntmp-x-1380) (let ((syntmp-x-1381 syntmp-x-1380)) (if (not (string? syntmp-x-1381)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1381)))) syntmp-messages-1378) (let ((syntmp-message-1382 (if (null? syntmp-messages-1378) "invalid syntax" (apply string-append syntmp-messages-1378)))) (syntmp-error-hook-78 #f syntmp-message-1382 (syntmp-strip-149 syntmp-object-1379 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1383 syntmp-v-1384) (begin (let ((syntmp-x-1385 syntmp-sym-1383)) (if (not (symbol? syntmp-x-1385)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1385))) (let ((syntmp-x-1386 syntmp-v-1384)) (if (not (procedure? syntmp-x-1386)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1386))) (syntmp-global-extend-100 (quote macro) syntmp-sym-1383 syntmp-v-1384)))) (letrec ((syntmp-match-1391 (lambda (syntmp-e-1392 syntmp-p-1393 syntmp-w-1394 syntmp-r-1395) (cond ((not syntmp-r-1395) #f) ((eq? syntmp-p-1393 (quote any)) (cons (syntmp-wrap-130 syntmp-e-1392 syntmp-w-1394) syntmp-r-1395)) ((syntmp-syntax-object?-88 syntmp-e-1392) (syntmp-match*-1390 (let ((syntmp-e-1396 (syntmp-syntax-object-expression-89 syntmp-e-1392))) (if (annotation? syntmp-e-1396) (annotation-expression syntmp-e-1396) syntmp-e-1396)) syntmp-p-1393 (syntmp-join-wraps-121 syntmp-w-1394 (syntmp-syntax-object-wrap-90 syntmp-e-1392)) syntmp-r-1395)) (else (syntmp-match*-1390 (let ((syntmp-e-1397 syntmp-e-1392)) (if (annotation? syntmp-e-1397) (annotation-expression syntmp-e-1397) syntmp-e-1397)) syntmp-p-1393 syntmp-w-1394 syntmp-r-1395))))) (syntmp-match*-1390 (lambda (syntmp-e-1398 syntmp-p-1399 syntmp-w-1400 syntmp-r-1401) (cond ((null? syntmp-p-1399) (and (null? syntmp-e-1398) syntmp-r-1401)) ((pair? syntmp-p-1399) (and (pair? syntmp-e-1398) (syntmp-match-1391 (car syntmp-e-1398) (car syntmp-p-1399) syntmp-w-1400 (syntmp-match-1391 (cdr syntmp-e-1398) (cdr syntmp-p-1399) syntmp-w-1400 syntmp-r-1401)))) ((eq? syntmp-p-1399 (quote each-any)) (let ((syntmp-l-1402 (syntmp-match-each-any-1388 syntmp-e-1398 syntmp-w-1400))) (and syntmp-l-1402 (cons syntmp-l-1402 syntmp-r-1401)))) (else (let ((syntmp-t-1403 (vector-ref syntmp-p-1399 0))) (if (memv syntmp-t-1403 (quote (each))) (if (null? syntmp-e-1398) (syntmp-match-empty-1389 (vector-ref syntmp-p-1399 1) syntmp-r-1401) (let ((syntmp-l-1404 (syntmp-match-each-1387 syntmp-e-1398 (vector-ref syntmp-p-1399 1) syntmp-w-1400))) (and syntmp-l-1404 (let syntmp-collect-1405 ((syntmp-l-1406 syntmp-l-1404)) (if (null? (car syntmp-l-1406)) syntmp-r-1401 (cons (map car syntmp-l-1406) (syntmp-collect-1405 (map cdr syntmp-l-1406)))))))) (if (memv syntmp-t-1403 (quote (free-id))) (and (syntmp-id?-102 syntmp-e-1398) (syntmp-free-id=?-125 (syntmp-wrap-130 syntmp-e-1398 syntmp-w-1400) (vector-ref syntmp-p-1399 1)) syntmp-r-1401) (if (memv syntmp-t-1403 (quote (atom))) (and (equal? (vector-ref syntmp-p-1399 1) (syntmp-strip-149 syntmp-e-1398 syntmp-w-1400)) syntmp-r-1401) (if (memv syntmp-t-1403 (quote (vector))) (and (vector? syntmp-e-1398) (syntmp-match-1391 (vector->list syntmp-e-1398) (vector-ref syntmp-p-1399 1) syntmp-w-1400 syntmp-r-1401))))))))))) (syntmp-match-empty-1389 (lambda (syntmp-p-1407 syntmp-r-1408) (cond ((null? syntmp-p-1407) syntmp-r-1408) ((eq? syntmp-p-1407 (quote any)) (cons (quote ()) syntmp-r-1408)) ((pair? syntmp-p-1407) (syntmp-match-empty-1389 (car syntmp-p-1407) (syntmp-match-empty-1389 (cdr syntmp-p-1407) syntmp-r-1408))) ((eq? syntmp-p-1407 (quote each-any)) (cons (quote ()) syntmp-r-1408)) (else (let ((syntmp-t-1409 (vector-ref syntmp-p-1407 0))) (if (memv syntmp-t-1409 (quote (each))) (syntmp-match-empty-1389 (vector-ref syntmp-p-1407 1) syntmp-r-1408) (if (memv syntmp-t-1409 (quote (free-id atom))) syntmp-r-1408 (if (memv syntmp-t-1409 (quote (vector))) (syntmp-match-empty-1389 (vector-ref syntmp-p-1407 1) syntmp-r-1408))))))))) (syntmp-match-each-any-1388 (lambda (syntmp-e-1410 syntmp-w-1411) (cond ((annotation? syntmp-e-1410) (syntmp-match-each-any-1388 (annotation-expression syntmp-e-1410) syntmp-w-1411)) ((pair? syntmp-e-1410) (let ((syntmp-l-1412 (syntmp-match-each-any-1388 (cdr syntmp-e-1410) syntmp-w-1411))) (and syntmp-l-1412 (cons (syntmp-wrap-130 (car syntmp-e-1410) syntmp-w-1411) syntmp-l-1412)))) ((null? syntmp-e-1410) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1410) (syntmp-match-each-any-1388 (syntmp-syntax-object-expression-89 syntmp-e-1410) (syntmp-join-wraps-121 syntmp-w-1411 (syntmp-syntax-object-wrap-90 syntmp-e-1410)))) (else #f)))) (syntmp-match-each-1387 (lambda (syntmp-e-1413 syntmp-p-1414 syntmp-w-1415) (cond ((annotation? syntmp-e-1413) (syntmp-match-each-1387 (annotation-expression syntmp-e-1413) syntmp-p-1414 syntmp-w-1415)) ((pair? syntmp-e-1413) (let ((syntmp-first-1416 (syntmp-match-1391 (car syntmp-e-1413) syntmp-p-1414 syntmp-w-1415 (quote ())))) (and syntmp-first-1416 (let ((syntmp-rest-1417 (syntmp-match-each-1387 (cdr syntmp-e-1413) syntmp-p-1414 syntmp-w-1415))) (and syntmp-rest-1417 (cons syntmp-first-1416 syntmp-rest-1417)))))) ((null? syntmp-e-1413) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1413) (syntmp-match-each-1387 (syntmp-syntax-object-expression-89 syntmp-e-1413) syntmp-p-1414 (syntmp-join-wraps-121 syntmp-w-1415 (syntmp-syntax-object-wrap-90 syntmp-e-1413)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1418 syntmp-p-1419) (cond ((eq? syntmp-p-1419 (quote any)) (list syntmp-e-1418)) ((syntmp-syntax-object?-88 syntmp-e-1418) (syntmp-match*-1390 (let ((syntmp-e-1420 (syntmp-syntax-object-expression-89 syntmp-e-1418))) (if (annotation? syntmp-e-1420) (annotation-expression syntmp-e-1420) syntmp-e-1420)) syntmp-p-1419 (syntmp-syntax-object-wrap-90 syntmp-e-1418) (quote ()))) (else (syntmp-match*-1390 (let ((syntmp-e-1421 syntmp-e-1418)) (if (annotation? syntmp-e-1421) (annotation-expression syntmp-e-1421) syntmp-e-1421)) syntmp-p-1419 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-138)))))
+(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1422) ((lambda (syntmp-tmp-1423) ((lambda (syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda (syntmp-_-1425 syntmp-e1-1426 syntmp-e2-1427) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1426 syntmp-e2-1427))) syntmp-tmp-1424) ((lambda (syntmp-tmp-1429) (if syntmp-tmp-1429 (apply (lambda (syntmp-_-1430 syntmp-out-1431 syntmp-in-1432 syntmp-e1-1433 syntmp-e2-1434) (list (quote #(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"))))) syntmp-in-1432 (quote ()) (list syntmp-out-1431 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1433 syntmp-e2-1434))))) syntmp-tmp-1429) ((lambda (syntmp-tmp-1436) (if syntmp-tmp-1436 (apply (lambda (syntmp-_-1437 syntmp-out-1438 syntmp-in-1439 syntmp-e1-1440 syntmp-e2-1441) (list (quote #(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"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1439) (quote ()) (list syntmp-out-1438 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1440 syntmp-e2-1441))))) syntmp-tmp-1436) (syntax-error syntmp-tmp-1423))) (syntax-dispatch syntmp-tmp-1423 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1423 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1423 (quote (any () any . each-any))))) syntmp-x-1422)))
+(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1463) ((lambda (syntmp-tmp-1464) ((lambda (syntmp-tmp-1465) (if syntmp-tmp-1465 (apply (lambda (syntmp-_-1466 syntmp-k-1467 syntmp-keyword-1468 syntmp-pattern-1469 syntmp-template-1470) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(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"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1467 (map (lambda (syntmp-tmp-1473 syntmp-tmp-1472) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1472) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1473))) syntmp-template-1470 syntmp-pattern-1469)))))) syntmp-tmp-1465) (syntax-error syntmp-tmp-1464))) (syntax-dispatch syntmp-tmp-1464 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1463)))
+(install-global-transformer (quote let*) (lambda (syntmp-x-1484) ((lambda (syntmp-tmp-1485) ((lambda (syntmp-tmp-1486) (if (if syntmp-tmp-1486 (apply (lambda (syntmp-let*-1487 syntmp-x-1488 syntmp-v-1489 syntmp-e1-1490 syntmp-e2-1491) (andmap identifier? syntmp-x-1488)) syntmp-tmp-1486) #f) (apply (lambda (syntmp-let*-1493 syntmp-x-1494 syntmp-v-1495 syntmp-e1-1496 syntmp-e2-1497) (let syntmp-f-1498 ((syntmp-bindings-1499 (map list syntmp-x-1494 syntmp-v-1495))) (if (null? syntmp-bindings-1499) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1496 syntmp-e2-1497))) ((lambda (syntmp-tmp-1503) ((lambda (syntmp-tmp-1504) (if syntmp-tmp-1504 (apply (lambda (syntmp-body-1505 syntmp-binding-1506) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1506) syntmp-body-1505)) syntmp-tmp-1504) (syntax-error syntmp-tmp-1503))) (syntax-dispatch syntmp-tmp-1503 (quote (any any))))) (list (syntmp-f-1498 (cdr syntmp-bindings-1499)) (car syntmp-bindings-1499)))))) syntmp-tmp-1486) (syntax-error syntmp-tmp-1485))) (syntax-dispatch syntmp-tmp-1485 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1484)))
+(install-global-transformer (quote do) (lambda (syntmp-orig-x-1526) ((lambda (syntmp-tmp-1527) ((lambda (syntmp-tmp-1528) (if syntmp-tmp-1528 (apply (lambda (syntmp-_-1529 syntmp-var-1530 syntmp-init-1531 syntmp-step-1532 syntmp-e0-1533 syntmp-e1-1534 syntmp-c-1535) ((lambda (syntmp-tmp-1536) ((lambda (syntmp-tmp-1537) (if syntmp-tmp-1537 (apply (lambda (syntmp-step-1538) ((lambda (syntmp-tmp-1539) ((lambda (syntmp-tmp-1540) (if syntmp-tmp-1540 (apply (lambda () (list (quote #(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"))))) (quote #(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"))))) (map list syntmp-var-1530 syntmp-init-1531) (list (quote #(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"))))) (list (quote #(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"))))) syntmp-e0-1533) (cons (quote #(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"))))) (append syntmp-c-1535 (list (cons (quote #(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"))))) syntmp-step-1538))))))) syntmp-tmp-1540) ((lambda (syntmp-tmp-1545) (if syntmp-tmp-1545 (apply (lambda (syntmp-e1-1546 syntmp-e2-1547) (list (quote #(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"))))) (quote #(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"))))) (map list syntmp-var-1530 syntmp-init-1531) (list (quote #(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"))))) syntmp-e0-1533 (cons (quote #(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"))))) (cons syntmp-e1-1546 syntmp-e2-1547)) (cons (quote #(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"))))) (append syntmp-c-1535 (list (cons (quote #(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"))))) syntmp-step-1538))))))) syntmp-tmp-1545) (syntax-error syntmp-tmp-1539))) (syntax-dispatch syntmp-tmp-1539 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1539 (quote ())))) syntmp-e1-1534)) syntmp-tmp-1537) (syntax-error syntmp-tmp-1536))) (syntax-dispatch syntmp-tmp-1536 (quote each-any)))) (map (lambda (syntmp-v-1554 syntmp-s-1555) ((lambda (syntmp-tmp-1556) ((lambda (syntmp-tmp-1557) (if syntmp-tmp-1557 (apply (lambda () syntmp-v-1554) syntmp-tmp-1557) ((lambda (syntmp-tmp-1558) (if syntmp-tmp-1558 (apply (lambda (syntmp-e-1559) syntmp-e-1559) syntmp-tmp-1558) ((lambda (syntmp-_-1560) (syntax-error syntmp-orig-x-1526)) syntmp-tmp-1556))) (syntax-dispatch syntmp-tmp-1556 (quote (any)))))) (syntax-dispatch syntmp-tmp-1556 (quote ())))) syntmp-s-1555)) syntmp-var-1530 syntmp-step-1532))) syntmp-tmp-1528) (syntax-error syntmp-tmp-1527))) (syntax-dispatch syntmp-tmp-1527 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1526)))
+(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1588 (lambda (syntmp-x-1592 syntmp-y-1593) ((lambda (syntmp-tmp-1594) ((lambda (syntmp-tmp-1595) (if syntmp-tmp-1595 (apply (lambda (syntmp-x-1596 syntmp-y-1597) ((lambda (syntmp-tmp-1598) ((lambda (syntmp-tmp-1599) (if syntmp-tmp-1599 (apply (lambda (syntmp-dy-1600) ((lambda (syntmp-tmp-1601) ((lambda (syntmp-tmp-1602) (if syntmp-tmp-1602 (apply (lambda (syntmp-dx-1603) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1603 syntmp-dy-1600))) syntmp-tmp-1602) ((lambda (syntmp-_-1604) (if (null? syntmp-dy-1600) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596 syntmp-y-1597))) syntmp-tmp-1601))) (syntax-dispatch syntmp-tmp-1601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1596)) syntmp-tmp-1599) ((lambda (syntmp-tmp-1605) (if syntmp-tmp-1605 (apply (lambda (syntmp-stuff-1606) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1596 syntmp-stuff-1606))) syntmp-tmp-1605) ((lambda (syntmp-else-1607) (list (quote #(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 #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596 syntmp-y-1597)) syntmp-tmp-1598))) (syntax-dispatch syntmp-tmp-1598 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1598 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1597)) syntmp-tmp-1595) (syntax-error syntmp-tmp-1594))) (syntax-dispatch syntmp-tmp-1594 (quote (any any))))) (list syntmp-x-1592 syntmp-y-1593)))) (syntmp-quasiappend-1589 (lambda (syntmp-x-1608 syntmp-y-1609) ((lambda (syntmp-tmp-1610) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-x-1612 syntmp-y-1613) ((lambda (syntmp-tmp-1614) ((lambda (syntmp-tmp-1615) (if syntmp-tmp-1615 (apply (lambda () syntmp-x-1612) syntmp-tmp-1615) ((lambda (syntmp-_-1616) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1612 syntmp-y-1613)) syntmp-tmp-1614))) (syntax-dispatch syntmp-tmp-1614 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1613)) syntmp-tmp-1611) (syntax-error syntmp-tmp-1610))) (syntax-dispatch syntmp-tmp-1610 (quote (any any))))) (list syntmp-x-1608 syntmp-y-1609)))) (syntmp-quasivector-1590 (lambda (syntmp-x-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-x-1619) ((lambda (syntmp-tmp-1620) ((lambda (syntmp-tmp-1621) (if syntmp-tmp-1621 (apply (lambda (syntmp-x-1622) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1622))) syntmp-tmp-1621) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-x-1625) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1625)) syntmp-tmp-1624) ((lambda (syntmp-_-1627) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1619)) syntmp-tmp-1620))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1619)) syntmp-tmp-1618)) syntmp-x-1617))) (syntmp-quasi-1591 (lambda (syntmp-p-1628 syntmp-lev-1629) ((lambda (syntmp-tmp-1630) ((lambda (syntmp-tmp-1631) (if syntmp-tmp-1631 (apply (lambda (syntmp-p-1632) (if (= syntmp-lev-1629 0) syntmp-p-1632 (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1632) (- syntmp-lev-1629 1))))) syntmp-tmp-1631) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-p-1634 syntmp-q-1635) (if (= syntmp-lev-1629 0) (syntmp-quasiappend-1589 syntmp-p-1634 (syntmp-quasi-1591 syntmp-q-1635 syntmp-lev-1629)) (syntmp-quasicons-1588 (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1634) (- syntmp-lev-1629 1))) (syntmp-quasi-1591 syntmp-q-1635 syntmp-lev-1629)))) syntmp-tmp-1633) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda (syntmp-p-1637) (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1637) (+ syntmp-lev-1629 1)))) syntmp-tmp-1636) ((lambda (syntmp-tmp-1638) (if syntmp-tmp-1638 (apply (lambda (syntmp-p-1639 syntmp-q-1640) (syntmp-quasicons-1588 (syntmp-quasi-1591 syntmp-p-1639 syntmp-lev-1629) (syntmp-quasi-1591 syntmp-q-1640 syntmp-lev-1629))) syntmp-tmp-1638) ((lambda (syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-x-1642) (syntmp-quasivector-1590 (syntmp-quasi-1591 syntmp-x-1642 syntmp-lev-1629))) syntmp-tmp-1641) ((lambda (syntmp-p-1644) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1644)) syntmp-tmp-1630))) (syntax-dispatch syntmp-tmp-1630 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1630 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1628)))) (lambda (syntmp-x-1645) ((lambda (syntmp-tmp-1646) ((lambda (syntmp-tmp-1647) (if syntmp-tmp-1647 (apply (lambda (syntmp-_-1648 syntmp-e-1649) (syntmp-quasi-1591 syntmp-e-1649 0)) syntmp-tmp-1647) (syntax-error syntmp-tmp-1646))) (syntax-dispatch syntmp-tmp-1646 (quote (any any))))) syntmp-x-1645))))
+(install-global-transformer (quote include) (lambda (syntmp-x-1709) (letrec ((syntmp-read-file-1710 (lambda (syntmp-fn-1711 syntmp-k-1712) (let ((syntmp-p-1713 (open-input-file syntmp-fn-1711))) (let syntmp-f-1714 ((syntmp-x-1715 (read syntmp-p-1713))) (if (eof-object? syntmp-x-1715) (begin (close-input-port syntmp-p-1713) (quote ())) (cons (datum->syntax-object syntmp-k-1712 syntmp-x-1715) (syntmp-f-1714 (read syntmp-p-1713))))))))) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-k-1718 syntmp-filename-1719) (let ((syntmp-fn-1720 (syntax-object->datum syntmp-filename-1719))) ((lambda (syntmp-tmp-1721) ((lambda (syntmp-tmp-1722) (if syntmp-tmp-1722 (apply (lambda (syntmp-exp-1723) (cons (quote #(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"))))) syntmp-exp-1723)) syntmp-tmp-1722) (syntax-error syntmp-tmp-1721))) (syntax-dispatch syntmp-tmp-1721 (quote each-any)))) (syntmp-read-file-1710 syntmp-fn-1720 syntmp-k-1718)))) syntmp-tmp-1717) (syntax-error syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (any any))))) syntmp-x-1709))))
+(install-global-transformer (quote unquote) (lambda (syntmp-x-1740) ((lambda (syntmp-tmp-1741) ((lambda (syntmp-tmp-1742) (if syntmp-tmp-1742 (apply (lambda (syntmp-_-1743 syntmp-e-1744) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1744))) syntmp-tmp-1742) (syntax-error syntmp-tmp-1741))) (syntax-dispatch syntmp-tmp-1741 (quote (any any))))) syntmp-x-1740)))
+(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1750) ((lambda (syntmp-tmp-1751) ((lambda (syntmp-tmp-1752) (if syntmp-tmp-1752 (apply (lambda (syntmp-_-1753 syntmp-e-1754) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1754))) syntmp-tmp-1752) (syntax-error syntmp-tmp-1751))) (syntax-dispatch syntmp-tmp-1751 (quote (any any))))) syntmp-x-1750)))
+(install-global-transformer (quote case) (lambda (syntmp-x-1760) ((lambda (syntmp-tmp-1761) ((lambda (syntmp-tmp-1762) (if syntmp-tmp-1762 (apply (lambda (syntmp-_-1763 syntmp-e-1764 syntmp-m1-1765 syntmp-m2-1766) ((lambda (syntmp-tmp-1767) ((lambda (syntmp-body-1768) (list (quote #(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"))))) (list (list (quote #(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"))))) syntmp-e-1764)) syntmp-body-1768)) syntmp-tmp-1767)) (let syntmp-f-1769 ((syntmp-clause-1770 syntmp-m1-1765) (syntmp-clauses-1771 syntmp-m2-1766)) (if (null? syntmp-clauses-1771) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-tmp-1774) (if syntmp-tmp-1774 (apply (lambda (syntmp-e1-1775 syntmp-e2-1776) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1775 syntmp-e2-1776))) syntmp-tmp-1774) ((lambda (syntmp-tmp-1778) (if syntmp-tmp-1778 (apply (lambda (syntmp-k-1779 syntmp-e1-1780 syntmp-e2-1781) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1779)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1780 syntmp-e2-1781)))) syntmp-tmp-1778) ((lambda (syntmp-_-1784) (syntax-error syntmp-x-1760)) syntmp-tmp-1773))) (syntax-dispatch syntmp-tmp-1773 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1773 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1770) ((lambda (syntmp-tmp-1785) ((lambda (syntmp-rest-1786) ((lambda (syntmp-tmp-1787) ((lambda (syntmp-tmp-1788) (if syntmp-tmp-1788 (apply (lambda (syntmp-k-1789 syntmp-e1-1790 syntmp-e2-1791) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1789)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1790 syntmp-e2-1791)) syntmp-rest-1786)) syntmp-tmp-1788) ((lambda (syntmp-_-1794) (syntax-error syntmp-x-1760)) syntmp-tmp-1787))) (syntax-dispatch syntmp-tmp-1787 (quote (each-any any . each-any))))) syntmp-clause-1770)) syntmp-tmp-1785)) (syntmp-f-1769 (car syntmp-clauses-1771) (cdr syntmp-clauses-1771))))))) syntmp-tmp-1762) (syntax-error syntmp-tmp-1761))) (syntax-dispatch syntmp-tmp-1761 (quote (any any any . each-any))))) syntmp-x-1760)))
+(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1824) ((lambda (syntmp-tmp-1825) ((lambda (syntmp-tmp-1826) (if syntmp-tmp-1826 (apply (lambda (syntmp-_-1827 syntmp-e-1828) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1828)) (list (cons syntmp-_-1827 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1828 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1826) (syntax-error syntmp-tmp-1825))) (syntax-dispatch syntmp-tmp-1825 (quote (any any))))) syntmp-x-1824)))
(define fx= =)
(define fx< <)
-(define annotation? (lambda (x) #f))
-
(define top-level-eval-hook
(lambda (x)
(eval `(,noexpand ,x) (interaction-environment))))
;;; output constructors
-(begin
+(define (build-annotated src exp)
+ (if (and src (not (annotation? exp)))
+ (make-annotation exp src #t)
+ exp))
+
(define-syntax build-application
(syntax-rules ()
((_ source fun-exp arg-exps)
- `(,fun-exp . ,arg-exps))))
+ (build-annotated source `(,fun-exp . ,arg-exps)))))
(define-syntax build-conditional
(syntax-rules ()
((_ source test-exp then-exp else-exp)
- `(if ,test-exp ,then-exp ,else-exp))))
+ (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
(define-syntax build-lexical-reference
(syntax-rules ()
((_ type source var)
- var)))
+ (build-annotated source var))))
(define-syntax build-lexical-assignment
(syntax-rules ()
((_ source var exp)
- `(set! ,var ,exp))))
+ (build-annotated source `(set! ,var ,exp)))))
(define-syntax build-global-reference
(syntax-rules ()
((_ source var)
- var)))
+ (build-annotated source var))))
(define-syntax build-global-assignment
(syntax-rules ()
((_ source var exp)
- `(set! ,var ,exp))))
+ (build-annotated source `(set! ,var ,exp)))))
(define-syntax build-global-definition
(syntax-rules ()
((_ source var exp)
- `(define ,var ,exp))))
+ (build-annotated source `(define ,var ,exp)))))
(define-syntax build-lambda
(syntax-rules ()
((_ src vars exp)
- `(lambda ,vars ,exp))))
+ (build-annotated src `(lambda ,vars ,exp)))))
(define-syntax build-primref
(syntax-rules ()
- ((_ src name) name)
- ((_ src level name) name)))
+ ((_ src name) (build-annotated src name))
+ ((_ src level name) (build-annotated src name))))
(define (build-data src exp)
(if (and (self-evaluating? exp)
(not (vector? exp)))
- exp
- (list 'quote exp)))
+ (build-annotated src exp)
+ (build-annotated src (list 'quote exp))))
(define build-sequence
(lambda (src exps)
(if (null? (cdr exps))
- (car exps)
- `(begin ,@exps))))
+ (build-annotated src (car exps))
+ (build-annotated src `(begin ,@exps)))))
(define build-let
(lambda (src vars val-exps body-exp)
(if (null? vars)
- body-exp
- `(let ,(map list vars val-exps) ,body-exp))))
+ (build-annotated src body-exp)
+ (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
(define build-named-let
(lambda (src vars val-exps body-exp)
(if (null? vars)
- body-exp
- `(let ,(car vars) ,(map list (cdr vars) val-exps) ,body-exp))))
+ (build-annotated src body-exp)
+ (build-annotated src
+ `(let ,(car vars)
+ ,(map list (cdr vars) val-exps) ,body-exp)))))
(define build-letrec
(lambda (src vars val-exps body-exp)
(if (null? vars)
- body-exp
- `(letrec ,(map list vars val-exps) ,body-exp))))
+ (build-annotated src body-exp)
+ (build-annotated src
+ `(letrec ,(map list vars val-exps) ,body-exp)))))
(define-syntax build-lexical-var
(syntax-rules ()
- ((_ src id) (gensym (symbol->string id)))))
-)
+ ((_ src id) (build-annotated src (gensym (symbol->string id))))))
(define-structure (syntax-object expression wrap))
(cond
((pair? x)
(let ((new (cons #f #f)))
- (when parent (set-annotation-stripped! parent new))
+ (if parent (set-annotation-stripped! parent new))
(set-car! new (strip-annotation (car x) #f))
(set-cdr! new (strip-annotation (cdr x) #f))
new))
(strip-annotation (annotation-expression x) x)))
((vector? x)
(let ((new (make-vector (vector-length x))))
- (when parent (set-annotation-stripped! parent new))
+ (if 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))
;;;
;;; 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)))))))))
;;;;
add-name-help-handler! remove-name-help-handler!
apropos apropos-internal apropos-fold apropos-fold-accessible
apropos-fold-exported apropos-fold-all source arity
- system-module module-commentary))
+ procedure-arguments
+ module-commentary))
\f
;;; 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.
-You don't seem to have regular expressions installed.\n"))
+ (cond ((not (= (length exp) 1))
+ (help-usage)
+ '(begin))
+ ((not (provided? 'regex))
+ (display "`help' depends on the `regex' feature.
+You don't seem to have regular expressions installed.\n")
+ '(begin))
+ (else
+ (let ((name (car exp))
+ (not-found (lambda (type x)
+ (simple-format #t "No ~A found for ~A\n"
+ type x))))
+ (cond
+
+ ;; User-specified
+ ((try-name-help name)
+ => (lambda (x) (if (not (eq? x #t)) (display x))))
+
+ ;; 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))
+ (let ((doc (try-value-help (cadr name)
+ (local-eval (cadr name) env))))
+ (cond ((not doc) (not-found 'documentation (cadr name)))
+ ((eq? doc #t)) ;; pass
+ (else (write-line doc)))))
+
+ ;; (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
-
- ;; User-specified
- ((try-name-help name)
- => (lambda (x) (if (not (eq? x #t)) (display x))))
-
- ;; 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))
- (let ((doc (try-value-help (cadr name)
- (local-eval (cadr name) env))))
- (cond ((not doc) (not-found 'documentation (cadr name)))
- ((eq? doc #t)) ;; pass
- (else (write-line doc)))))
-
- ;; (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))
(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."))))))
+
+(define (procedure-arguments proc)
+ "Return an alist describing the arguments that `proc' accepts, or `#f'
+if the information cannot be obtained.
+
+The alist keys that are currently defined are `required', `optional',
+`keyword', and `rest'."
+ (cond
+ ((procedure-property proc 'arglist)
+ => (lambda (arglist)
+ `((required . ,(car arglist))
+ (optional . ,(cadr arglist))
+ (keyword . ,(caddr arglist))
+ (rest . ,(car (cddddr arglist))))))
+ ((procedure-source proc)
+ => cadr)
+ (((@ (system vm program) program?) proc)
+ ((@ (system vm program) program-arguments) proc))
+ (else #f)))
+
;;; session.scm ends here
(catch key
thunk
handler
- lazy-handler-dispatch))
+ pre-unwind-handler-dispatch))
;;; (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=?))
\f
(define expansion-eval-closure (make-fluid))
+(define (current-eval-closure)
+ (or (fluid-ref expansion-eval-closure)
+ (module-eval-closure (current-module))))
(define (env->eval-closure env)
- (or (and env
- (car (last-pair env)))
- (module-eval-closure the-root-module)))
+ (and env (car (last-pair env))))
+
+(define (annotation? x) #f)
(define sc-macro
(procedure->memoizing-macro
(fluid-set! expansion-eval-closure the-syncase-eval-closure)
(define (putprop symbol key binding)
- (let* ((eval-closure (fluid-ref expansion-eval-closure))
+ (let* ((eval-closure (current-eval-closure))
;; Why not simply do (eval-closure symbol #t)?
;; Answer: That would overwrite imported bindings
(v (or (eval-closure symbol #f) ;lookup
(set-object-property! v key binding)))
(define (getprop symbol key)
- (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
+ (let* ((v ((current-eval-closure) symbol #f)))
(and v
(or (object-property v key)
(and (variable-bound? v)
(if (symbol? e)
;; pass the expression through
e
- (let* ((eval-closure (fluid-ref expansion-eval-closure))
+ (let* ((eval-closure (current-eval-closure))
(m (variable-ref (eval-closure (car e) #f))))
(if (eq? (macro-type m) 'syntax)
;; pass the expression through
(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))))
;;; 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)))
;(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)
\f
-(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))
--- /dev/null
+;;; Guile Virtual Machine Assembly
+
+;; Copyright (C) 2001, 2009 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 assembly)
+ #:use-module (system base pmatch)
+ #:use-module (system vm instruction)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export (byte-length
+ addr+ align-program
+ assembly-pack assembly-unpack
+ object->assembly assembly->object))
+
+;; nargs, nrest, nlocs, nexts, len, metalen
+(define *program-header-len* (+ 1 1 1 1 4 4))
+
+;; lengths are encoded in 3 bytes
+(define *len-len* 3)
+
+(define (byte-length assembly)
+ (pmatch assembly
+ (,label (guard (not (pair? label)))
+ 0)
+ ((load-unsigned-integer ,str)
+ (+ 1 *len-len* (string-length str)))
+ ((load-integer ,str)
+ (+ 1 *len-len* (string-length str)))
+ ((load-number ,str)
+ (+ 1 *len-len* (string-length str)))
+ ((load-string ,str)
+ (+ 1 *len-len* (string-length str)))
+ ((load-symbol ,str)
+ (+ 1 *len-len* (string-length str)))
+ ((load-keyword ,str)
+ (+ 1 *len-len* (string-length str)))
+ ((define ,str)
+ (+ 1 *len-len* (string-length str)))
+ ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+ (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
+ ((,inst . _) (guard (>= (instruction-length inst) 0))
+ (+ 1 (instruction-length inst)))
+ (else (error "unknown instruction" assembly))))
+
+
+(define *program-alignment* 8)
+
+(define (addr+ addr code)
+ (fold (lambda (x len) (+ (byte-length x) len))
+ addr
+ code))
+
+(define (align-program prog addr)
+ `(,@(make-list (modulo (- *program-alignment*
+ (modulo (1+ addr) *program-alignment*))
+ ;; plus the one for the load-program inst itself
+ *program-alignment*)
+ '(nop))
+ ,prog))
+
+;;;
+;;; Code compress/decompression
+;;;
+
+(define *abbreviations*
+ '(((make-int8 0) . (make-int8:0))
+ ((make-int8 1) . (make-int8:1))))
+
+(define *expansions*
+ (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
+
+(define (assembly-pack code)
+ (or (assoc-ref *abbreviations* code)
+ code))
+
+(define (assembly-unpack code)
+ (or (assoc-ref *expansions* code)
+ code))
+
+\f
+;;;
+;;; Encoder/decoder
+;;;
+
+(define (object->assembly 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 (assembly->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)))
--- /dev/null
+;;; Guile VM assembler
+
+;; Copyright (C) 2001, 2009 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 assembly compile-bytecode)
+ #:use-module (system base pmatch)
+ #:use-module (language assembly)
+ #:use-module (system vm instruction)
+ #:use-module (srfi srfi-4)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module ((system vm objcode) #:select (byte-order))
+ #:export (compile-bytecode write-bytecode))
+
+(define (compile-bytecode assembly env . opts)
+ (pmatch assembly
+ ((load-program . _)
+ ;; the 1- and -1 are so that we drop the load-program byte
+ (letrec ((v (make-u8vector (1- (byte-length assembly))))
+ (i -1)
+ (write-byte (lambda (b)
+ (if (>= i 0) (u8vector-set! v i b))
+ (set! i (1+ i))))
+ (get-addr (lambda () i)))
+ (write-bytecode assembly write-byte get-addr '())
+ (if (= i (u8vector-length v))
+ (values v env)
+ (error "incorrect length in assembly" i (u8vector-length v)))))
+ (else (error "bad assembly" assembly))))
+
+(define (write-bytecode asm write-byte get-addr labels)
+ (define (write-char c)
+ (write-byte (char->integer c)))
+ (define (write-string s)
+ (string-for-each write-char s))
+ (define (write-uint16-be x)
+ (write-byte (logand (ash x -8) 255))
+ (write-byte (logand x 255)))
+ (define (write-uint16-le x)
+ (write-byte (logand x 255))
+ (write-byte (logand (ash x -8) 255)))
+ (define (write-uint32-be x)
+ (write-byte (logand (ash x -24) 255))
+ (write-byte (logand (ash x -16) 255))
+ (write-byte (logand (ash x -8) 255))
+ (write-byte (logand x 255)))
+ (define (write-uint32-le x)
+ (write-byte (logand x 255))
+ (write-byte (logand (ash x -8) 255))
+ (write-byte (logand (ash x -16) 255))
+ (write-byte (logand (ash x -24) 255)))
+ (define (write-loader-len len)
+ (write-byte (ash len -16))
+ (write-byte (logand (ash len -8) 255))
+ (write-byte (logand len 255)))
+ (define (write-loader str)
+ (write-loader-len (string-length str))
+ (write-string str))
+ (define (write-break label)
+ (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2))))
+
+ (let ((inst (car asm))
+ (args (cdr asm))
+ (write-uint32 (case byte-order
+ ((1234) write-uint32-le)
+ ((4321) write-uint32-be)
+ (else (error "unknown endianness" byte-order)))))
+ (let ((opcode (instruction->opcode inst))
+ (len (instruction-length inst)))
+ (write-byte opcode)
+ (pmatch asm
+ ((load-program ,nargs ,nrest ,nlocs ,nexts
+ ,labels ,length ,meta . ,code)
+ (write-byte nargs)
+ (write-byte nrest)
+ (write-byte nlocs)
+ (write-byte nexts)
+ (write-uint32 length)
+ (write-uint32 (if meta (1- (byte-length meta)) 0))
+ (letrec ((i 0)
+ (write (lambda (x) (set! i (1+ i)) (write-byte x)))
+ (get-addr (lambda () i)))
+ (for-each (lambda (asm)
+ (write-bytecode asm write get-addr labels))
+ code))
+ (if meta
+ ;; don't write the load-program byte for metadata
+ (letrec ((i -1)
+ (write (lambda (x)
+ (set! i (1+ i))
+ (if (> i 0) (write-byte x))))
+ (get-addr (lambda () i)))
+ (write-bytecode meta write get-addr '()))))
+ ((load-unsigned-integer ,str) (write-loader str))
+ ((load-integer ,str) (write-loader str))
+ ((load-number ,str) (write-loader str))
+ ((load-string ,str) (write-loader str))
+ ((load-symbol ,str) (write-loader str))
+ ((load-keyword ,str) (write-loader str))
+ ((define ,str) (write-loader str))
+ ((br ,l) (write-break l))
+ ((br-if ,l) (write-break l))
+ ((br-if-not ,l) (write-break l))
+ ((br-if-eq ,l) (write-break l))
+ ((br-if-not-eq ,l) (write-break l))
+ ((br-if-null ,l) (write-break l))
+ ((br-if-not-null ,l) (write-break l))
+ ((mv-call ,n ,l) (write-byte n) (write-break l))
+ (else
+ (cond
+ ((< (instruction-length inst) 0)
+ (error "unhanded variable-length instruction" asm))
+ ((not (= (length args) len))
+ (error "bad number of args to instruction" asm len))
+ (else
+ (for-each write-byte args))))))))
--- /dev/null
+;;; Guile VM code converters
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language assembly decompile-bytecode)
+ #:use-module (system vm instruction)
+ #:use-module (system base pmatch)
+ #:use-module (srfi srfi-4)
+ #:use-module (language assembly)
+ #:export (decompile-bytecode))
+
+(define (decompile-bytecode x env opts)
+ (let ((i 0) (size (u8vector-length x)))
+ (define (pop)
+ (let ((b (cond ((< i size) (u8vector-ref x i))
+ ((= i size) #f)
+ (else (error "tried to decode too many bytes")))))
+ (if b (set! i (1+ i)))
+ b))
+ (let ((ret (decode-load-program pop)))
+ (if (= i size)
+ (values ret env)
+ (error "bad bytecode: only decoded ~a out of ~a bytes" i size)))))
+
+(define (decode-load-program pop)
+ (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
+ (a (pop)) (b (pop)) (c (pop)) (d (pop))
+ (e (pop)) (f (pop)) (g (pop)) (h (pop))
+ (len (+ a (ash b 8) (ash c 16) (ash d 24)))
+ (metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
+ (totlen (+ len metalen))
+ (i 0))
+ (define (sub-pop) ;; ...records. ha. ha.
+ (let ((b (cond ((< i len) (pop))
+ ((= i len) #f)
+ (else (error "tried to decode too many bytes")))))
+ (if b (set! i (1+ i)))
+ b))
+ (let lp ((out '()))
+ (cond ((> i len)
+ (error "error decoding program -- read too many bytes" out))
+ ((= i len)
+ `(load-program ,nargs ,nrest ,nlocs ,nexts () ,len
+ ,(if (zero? metalen) #f (decode-load-program pop))
+ ,@(reverse! out)))
+ (else
+ (let ((exp (decode-bytecode sub-pop)))
+ ;; replace with labels?
+ (lp (cons exp out))))))))
+
+(define (decode-bytecode pop)
+ (and=> (pop)
+ (lambda (opcode)
+ (let ((inst (opcode->instruction opcode)))
+ (cond
+ ((eq? inst 'load-program)
+ (decode-load-program pop))
+ ((< (instruction-length inst) 0)
+ (let* ((len (let* ((a (pop)) (b (pop)) (c (pop)))
+ (+ (ash a 16) (ash b 8) c)))
+ (str (make-string len)))
+ (let lp ((i 0))
+ (if (= i len)
+ `(,inst ,str)
+ (begin
+ (string-set! str i (integer->char (pop)))
+ (lp (1+ i)))))))
+ (else
+ ;; fixed length
+ (let lp ((n (instruction-length inst)) (out (list inst)))
+ (if (zero? n)
+ (reverse! out)
+ (lp (1- n) (cons (pop) out))))))))))
--- /dev/null
+;;; Guile VM code converters
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language assembly disassemble)
+ #:use-module (ice-9 format)
+ #:use-module (system vm instruction)
+ #:use-module (system vm program)
+ #:use-module (system base pmatch)
+ #:use-module (language assembly)
+ #:use-module (system base compile)
+ #:export (disassemble))
+
+(define (disassemble x)
+ (format #t "Disassembly of ~A:\n\n" x)
+ (call-with-values
+ (lambda () (decompile x #:from 'value #:to 'assembly))
+ disassemble-load-program))
+
+(define (disassemble-load-program asm env)
+ (pmatch asm
+ ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+ (let ((objs (and env (assq-ref env 'objects)))
+ (meta (and env (assq-ref env 'meta)))
+ (exts (and env (assq-ref env 'exts)))
+ (blocs (and env (assq-ref env 'blocs)))
+ (bexts (and env (assq-ref env 'bexts)))
+ (srcs (and env (assq-ref env 'sources))))
+ (let lp ((pos 0) (code code) (programs '()))
+ (cond
+ ((null? code)
+ (newline)
+ (for-each
+ (lambda (sym+asm)
+ (format #t "Embedded program ~A:\n\n" (car sym+asm))
+ (disassemble-load-program (cdr sym+asm) '()))
+ (reverse! programs)))
+ (else
+ (let* ((asm (car code))
+ (len (byte-length asm))
+ (end (+ pos len)))
+ (pmatch asm
+ ((load-program . _)
+ (let ((sym (gensym "")))
+ (print-info pos `(load-program ,sym) #f #f)
+ (lp (+ pos (byte-length asm)) (cdr code)
+ (acons sym asm programs))))
+ (else
+ (print-info pos asm
+ (code-annotation end asm objs nargs blocs bexts)
+ (and=> (and srcs (assq end srcs)) source->string))
+ (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
+
+ (if (pair? exts)
+ (disassemble-externals exts))
+ (if meta
+ (disassemble-meta meta))
+
+ ;; Disassemble other bytecode in it
+ ;; FIXME: something about the module.
+ (if objs
+ (for-each
+ (lambda (x)
+ (if (program? x)
+ (begin (display "----------------------------------------\n")
+ (disassemble x))))
+ (cddr (vector->list objs))))))
+ (else
+ (error "bad load-program form" asm))))
+
+(define (disassemble-objects objs)
+ (display "Objects:\n\n")
+ (let ((len (vector-length objs)))
+ (do ((n 0 (1+ n)))
+ ((= n len) (newline))
+ (print-info n (vector-ref objs n) #f #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))
+ (print-info n (car l) #f #f))))
+
+(define-macro (unless test . body)
+ `(if (not ,test) (begin ,@body)))
+
+(define *uninteresting-props* '(name))
+
+(define (disassemble-meta meta)
+ (let ((sources (cadr meta))
+ (props (filter (lambda (x)
+ (not (memq (car x) *uninteresting-props*)))
+ (cddr meta))))
+ (unless (null? props)
+ (display "Properties:\n\n")
+ (for-each (lambda (x) (print-info #f x #f #f)) props)
+ (newline))))
+
+(define (source->string src)
+ (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
+ (source:line src) (source:column src)))
+
+(define (make-int16 byte1 byte2)
+ (+ (* byte1 256) byte2))
+
+(define (code-annotation end-addr code objs nargs blocs bexts)
+ (let* ((code (assembly-unpack code))
+ (inst (car code))
+ (args (cdr code)))
+ (case inst
+ ((list vector)
+ (list "~a element~:p" (apply make-int16 args)))
+ ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
+ (list "-> ~A" (+ end-addr (apply make-int16 args))))
+ ((object-ref)
+ (and objs (list "~s" (vector-ref objs (car args)))))
+ ((local-ref local-set)
+ (and blocs
+ (let lp ((bindings (list-ref blocs (car args))))
+ (and (pair? bindings)
+ (let ((b (car bindings)))
+ (if (and (< (binding:start (car bindings)) end-addr)
+ (>= (binding:end (car bindings)) end-addr))
+ (list "`~a'~@[ (arg)~]"
+ (binding:name b) (< (binding:index b) nargs))
+ (lp (cdr bindings))))))))
+ ((external-ref external-set)
+ (and bexts
+ (if (< (car args) (length bexts))
+ (let ((b (list-ref bexts (car args))))
+ (list "`~a'~@[ (arg)~]"
+ (binding:name b) (< (binding:index b) nargs)))
+ (list "(closure variable)"))))
+ ((toplevel-ref toplevel-set)
+ (and objs
+ (let ((v (vector-ref objs (car args))))
+ (if (and (variable? v) (variable-bound? v))
+ (list "~s" (variable-ref v))
+ (list "`~s'" v)))))
+ ((mv-call)
+ (list "MV -> ~A" (+ end-addr (apply make-int16 (cdr args)))))
+ (else
+ (and=> (assembly->object code)
+ (lambda (obj) (list "~s" obj)))))))
+
+;; i am format's daddy.
+(define (print-info addr info extra src)
+ (format #t "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src))
+
+(define (simplify x)
+ (cond ((string? x)
+ (cond ((string-index x #\newline) =>
+ (lambda (i) (set! x (substring x 0 i)))))
+ (cond ((> (string-length x) 16)
+ (set! x (string-append (substring x 0 13) "..."))))))
+ x)
+
--- /dev/null
+;;; Guile Virtual Machine Assembly
+
+;; 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 assembly spec)
+ #:use-module (system base language)
+ #:use-module (language assembly compile-bytecode)
+ #:use-module (language assembly decompile-bytecode)
+ #:export (assembly))
+
+(define-language assembly
+ #:title "Guile Virtual Machine Assembly Language"
+ #:version "2.0"
+ #:reader read
+ #:printer write
+ #:parser read ;; fixme: make a verifier?
+ #:compilers `((bytecode . ,compile-bytecode))
+ #:decompilers `((bytecode . ,decompile-bytecode))
+ )
--- /dev/null
+;;; Guile Lowlevel 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 bytecode spec)
+ #:use-module (system base language)
+ #:use-module (system vm objcode)
+ #:export (bytecode))
+
+(define (compile-objcode x e opts)
+ (values (bytecode->objcode x) e))
+
+(define (decompile-objcode x e opts)
+ (values (objcode->bytecode x) e))
+
+(define-language bytecode
+ #:title "Guile Bytecode Vectors"
+ #:version "0.3"
+ #:reader read
+ #:printer write
+ #:compilers `((objcode . ,compile-objcode))
+ #:decompilers `((objcode . ,decompile-objcode))
+ )
--- /dev/null
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 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 ecmascript array)
+ #:use-module (oop goops)
+ #:use-module (language ecmascript base)
+ #:use-module (language ecmascript function)
+ #:export (*array-prototype* new-array))
+
+
+(define-class <js-array-object> (<js-object>)
+ (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector))
+
+(define (new-array . vals)
+ (let ((o (make <js-array-object> #:class "Array"
+ #:prototype *array-prototype*)))
+ (pput o 'length (length vals))
+ (let ((vect (js-array-vector o)))
+ (let lp ((i 0) (vals vals))
+ (cond ((not (null? vals))
+ (vector-set! vect i (car vals))
+ (lp (1+ i) (cdr vals)))
+ (else o))))))
+
+(define *array-prototype* (make <js-object> #:class "Array"
+ #:value new-array
+ #:constructor new-array))
+
+(hashq-set! *program-wrappers* new-array *array-prototype*)
+
+(pput *array-prototype* 'prototype *array-prototype*)
+(pput *array-prototype* 'constructor new-array)
+
+(define-method (pget (o <js-array-object>) p)
+ (cond ((and (integer? p) (exact? p) (>= p 0))
+ (let ((v (js-array-vector o)))
+ (if (< p (vector-length v))
+ (vector-ref v p)
+ (next-method))))
+ ((or (and (symbol? p) (eq? p 'length))
+ (and (string? p) (string=? p "length")))
+ (vector-length (js-array-vector o)))
+ (else (next-method))))
+
+(define-method (pput (o <js-array-object>) p v)
+ (cond ((and (integer? p) (exact? p) (>= 0 p))
+ (let ((vect (js-array-vector o)))
+ (if (< p (vector-length vect))
+ (vector-set! vect p)
+ ;; Fixme: round up to powers of 2?
+ (let ((new (make-vector (1+ p) 0)))
+ (vector-move-left! vect 0 (vector-length vect) new 0)
+ (set! (js-array-vector o) new)
+ (vector-set! new p)))))
+ ((or (and (symbol? p) (eq? p 'length))
+ (and (string? p) (string=? p "length")))
+ (let ((vect (js-array-vector o)))
+ (let ((new (make-vector (->uint32 v) 0)))
+ (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v))
+ new 0)
+ (set! (js-array-vector o) new))))
+ (else (next-method))))
+
+(define-js-method *array-prototype* (toString)
+ (format #f "~A" (js-array-vector this)))
+
+(define-js-method *array-prototype* (concat . rest)
+ (let* ((len (apply + (->uint32 (pget this 'length))
+ (map (lambda (x) (->uint32 (pget x 'length)))
+ rest)))
+ (rv (make-vector len 0)))
+ (let lp ((objs (cons this rest)) (i 0))
+ (cond ((null? objs) (make <js-array-object> #:class "Array"
+ #:prototype *array-prototype*
+ #:vector rv))
+ ((is-a? (car objs) <js-array-object>)
+ (let ((v (js-array-vector (car objs))))
+ (vector-move-left! v 0 (vector-length v)
+ rv i (+ i (vector-length v)))
+ (lp (cdr objs) (+ i (vector-length v)))))
+ (else
+ (error "generic array concats not yet implemented"))))))
+
+(define-js-method *array-prototype* (join . separator)
+ (let lp ((i (1- (->uint32 (pget this 'length)))) (l '()))
+ (if (< i 0)
+ (string-join l (if separator (->string (car separator)) ","))
+ (lp (1+ i)
+ (cons (->string (pget this i)) l)))))
+
+(define-js-method *array-prototype* (pop)
+ (let ((len (->uint32 (pget this 'length))))
+ (if (zero? len)
+ *undefined*
+ (let ((ret (pget this (1- len))))
+ (pput this 'length (1- len))
+ ret))))
+
+(define-js-method *array-prototype* (push . args)
+ (let lp ((args args))
+ (if (null? args)
+ (->uint32 (pget this 'length))
+ (begin (pput this (->uint32 (pget this 'length)) (car args))
+ (lp (cdr args))))))
--- /dev/null
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 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 ecmascript base)
+ #:use-module (oop goops)
+ #:export (*undefined* *this*
+ <js-object> *object-prototype*
+ js-prototype js-props js-prop-attrs js-value js-constructor js-class
+ pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel
+
+ object->string object->number object->value/string
+ object->value/number object->value
+
+ ->primitive ->boolean ->number ->integer ->int32 ->uint32
+ ->uint16 ->string ->object
+
+ call/this* call/this lambda/this define-js-method
+
+ new-object new))
+
+(define *undefined* ((@@ (oop goops) make-unbound)))
+(define *this* (make-fluid))
+
+(define-class <js-object> ()
+ (prototype #:getter js-prototype #:init-keyword #:prototype
+ #:init-thunk (lambda () *object-prototype*))
+ (props #:getter js-props #:init-form (make-hash-table 7))
+ (prop-attrs #:getter js-prop-attrs #:init-value #f)
+ (value #:getter js-value #:init-value #f #:init-keyword #:value)
+ (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor)
+ (class #:getter js-class #:init-value "Object" #:init-keyword #:class))
+
+(define-method (prop-keys (o <js-object>))
+ (hash-map->list (lambda (k v) k) (js-props o)))
+
+(define-method (pget (o <js-object>) (p <string>))
+ (pget o (string->symbol p)))
+
+(define-method (pget (o <js-object>) p)
+ (let ((h (hashq-get-handle (js-props o) p)))
+ (if h
+ (cdr h)
+ (let ((proto (js-prototype o)))
+ (if proto
+ (pget proto p)
+ *undefined*)))))
+
+(define-method (prop-attrs (o <js-object>) p)
+ (or (let ((attrs (js-prop-attrs o)))
+ (and attrs (hashq-ref (js-prop-attrs o) p)))
+ (let ((proto (js-prototype o)))
+ (if proto
+ (prop-attrs proto p)
+ '()))))
+
+(define-method (prop-has-attr? (o <js-object>) p attr)
+ (memq attr (prop-attrs o p)))
+
+(define-method (pput (o <js-object>) p v)
+ (if (prop-has-attr? o p 'ReadOnly)
+ (throw 'ReferenceError o p)
+ (hashq-set! (js-props o) p v)))
+
+(define-method (pput (o <js-object>) (p <string>) v)
+ (pput o (string->symbol p) v))
+
+(define-method (pdel (o <js-object>) p)
+ (if (prop-has-attr? o p 'DontDelete)
+ #f
+ (begin
+ (pput o p *undefined*)
+ #t)))
+
+(define-method (pdel (o <js-object>) (p <string>) v)
+ (pdel o (string->symbol p)))
+
+(define-method (has-property? (o <js-object>) p)
+ (if (hashq-get-handle (js-props o) v)
+ #t
+ (let ((proto (js-prototype o)))
+ (if proto
+ (has-property? proto p)
+ #f))))
+
+(define (call/this* this f)
+ (with-fluid* *this* this f))
+
+(define-macro (call/this this f . args)
+ `(with-fluid* *this* ,this (lambda () (,f . ,args))))
+(define-macro (lambda/this formals . body)
+ `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body)))
+(define-macro (define-js-method object name-and-args . body)
+ `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body)))
+
+(define *object-prototype* #f)
+(set! *object-prototype* (make <js-object>))
+
+(define-js-method *object-prototype* (toString)
+ (format #f "[object ~A]" (js-class this)))
+(define-js-method *object-prototype* (toLocaleString . args)
+ ((pget *object-prototype* 'toString)))
+(define-js-method *object-prototype* (valueOf)
+ this)
+(define-js-method *object-prototype* (hasOwnProperty p)
+ (and (hashq-get-handle (js-props this) p) #t))
+(define-js-method *object-prototype* (isPrototypeOf v)
+ (eq? this (js-prototype v)))
+(define-js-method *object-prototype* (propertyIsEnumerable p)
+ (and (hashq-get-handle (js-props this) p)
+ (not (prop-has-attr? this p 'DontEnum))))
+
+(define (object->string o error?)
+ (let ((toString (pget o 'toString)))
+ (if (procedure? toString)
+ (let ((x (call/this o toString)))
+ (if (and error? (is-a? x <js-object>))
+ (throw 'TypeError o 'default-value)
+ x))
+ (if error?
+ (throw 'TypeError o 'default-value)
+ o))))
+
+(define (object->number o error?)
+ (let ((valueOf (pget o 'valueOf)))
+ (if (procedure? valueOf)
+ (let ((x (call/this o valueOf)))
+ (if (and error? (is-a? x <js-object>))
+ (throw 'TypeError o 'default-value)
+ x))
+ (if error?
+ (throw 'TypeError o 'default-value)
+ o))))
+
+(define (object->value/string o)
+ (let ((v (object->string o #f)))
+ (if (is-a? x <js-object>)
+ (object->number o #t)
+ x)))
+
+(define (object->value/number o)
+ (let ((v (object->number o #f)))
+ (if (is-a? x <js-object>)
+ (object->string o #t)
+ x)))
+
+(define (object->value o)
+ ;; FIXME: if it's a date, we should try numbers first
+ (object->value/string o))
+
+(define (->primitive x)
+ (if (is-a? x <js-object>)
+ (object->value x)
+ x))
+
+(define (->boolean x)
+ (not (or (not x) (null? x) (eq? x *undefined*) (zero? x) (nan? x)
+ (and (string? x) (= (string-length x) 0)))))
+
+(define (->number x)
+ (cond ((number? x) x)
+ ((boolean? x) (if x 1 0))
+ ((null? x) 0)
+ ((eq? x *undefined*) +nan.0)
+ ((is-a? x <js-object>) (object->number o))
+ ((string? x) (string->number x))
+ (else (throw 'TypeError o '->number))))
+
+(define (->integer x)
+ (let ((n (->number x)))
+ (cond ((nan? n) 0)
+ ((zero? n) n)
+ ((inf? n) n)
+ (else (inexact->exact (round n))))))
+
+(define (->int32 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n)))))
+ (if (negative? n)
+ (- m (ash 1 32))
+ m)))))
+
+(define (->uint32 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (logand (1- (ash 1 32)) (inexact->exact (round n))))))
+
+(define (->uint16 x)
+ (let ((n (->number x)))
+ (if (or (nan? n) (zero? n) (inf? n))
+ 0
+ (logand (1- (ash 1 16)) (inexact->exact (round n))))))
+
+(define (->string x)
+ (cond ((eq? x *undefined*) "undefined")
+ ((null? x) "null")
+ ((boolean? x) (if x "true" "false"))
+ ((string? x) x)
+ ((number? x)
+ (cond ((nan? x) "NaN")
+ ((zero? x) "0")
+ ((inf? x) "Infinity")
+ (else (number->string x))))
+ (else (->string (object->value/string x)))))
+
+(define (->object x)
+ (cond ((eq? x *undefined*) (throw 'TypeError x '->object))
+ ((null? x) (throw 'TypeError x '->object))
+ ((boolean? x) (make <js-object> #:prototype Boolean #:value x))
+ ((number? x) (make <js-object> #:prototype String #:value x))
+ ((string? x) (make <js-object> #:prototype Number #:value x))
+ (else x)))
+
+(define (new-object . pairs)
+ (let ((o (make <js-object>)))
+ (map (lambda (pair)
+ (pput o (car pair) (cdr pair)))
+ pairs)
+ o))
+(slot-set! *object-prototype* 'constructor new-object)
+
+(define-method (new o . initargs)
+ (let ((ctor (js-constructor o)))
+ (if (not ctor)
+ (throw 'TypeError 'new o)
+ (let ((o (make <js-object>
+ #:prototype (or (js-prototype o) *object-prototype*))))
+ (let ((new-o (call/this o apply ctor initargs)))
+ (if (is-a? new-o <js-object>)
+ new-o
+ o))))))
--- /dev/null
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 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 ecmascript compile-ghil)
+ #:use-module (language ghil)
+ #:use-module (ice-9 receive)
+ #:use-module (system base pmatch)
+ #:export (compile-ghil))
+
+(define-macro (-> form)
+ `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
+
+(define-macro (@implv sym)
+ `(-> (ref (ghil-var-at-module! e '(language ecmascript impl) ',sym #t))))
+(define-macro (@impl sym args)
+ `(-> (call (@implv ,sym) ,args)))
+
+(define (compile-ghil exp env opts)
+ (values
+ (call-with-ghil-environment (make-ghil-toplevel-env) '()
+ (lambda (e vars)
+ (let ((l #f))
+ (-> (lambda vars #f '()
+ (-> (begin (list (@impl js-init '())
+ (comp exp e)))))))))
+ env))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+;; The purpose, you ask? To avoid non-tail recursion when expanding a
+;; long pmatch sequence.
+(define-macro (ormatch x . clauses)
+ (let ((X (gensym)))
+ `(let ((,X ,x))
+ (or ,@(map (lambda (c)
+ (if (eq? (car c) 'else)
+ `(begin . ,(cdr c))
+ `(pmatch ,X ,c (else #f))))
+ clauses)))))
+
+(define (comp x e)
+ (let ((l (location x)))
+ (define (let1 what proc)
+ (call-with-ghil-bindings e '(%tmp)
+ (lambda (vars)
+ (-> (bind vars (list what)
+ (proc (car vars)))))))
+ (define (begin1 what proc)
+ (call-with-ghil-bindings e '(%tmp)
+ (lambda (vars)
+ (-> (bind vars (list what)
+ (-> (begin (list (proc (car vars))
+ (-> (ref (car vars)))))))))))
+ (ormatch x
+ (null
+ ;; FIXME, null doesn't have much relation to EOL...
+ (-> (quote '())))
+ (true
+ (-> (quote #t)))
+ (false
+ (-> (quote #f)))
+ ((number ,num)
+ (-> (quote num)))
+ ((string ,str)
+ (-> (quote str)))
+ (this
+ (@impl get-this '()))
+ ((+ ,a)
+ (-> (inline 'add
+ (list (@impl ->number (list (comp a e)))
+ (-> (quote 0))))))
+ ((- ,a)
+ (-> (inline 'sub (list (-> (quote 0)) (comp a e)))))
+ ((~ ,a)
+ (@impl bitwise-not (list (comp a e))))
+ ((! ,a)
+ (@impl logical-not (list (comp a e))))
+ ((+ ,a ,b)
+ (-> (inline 'add (list (comp a e) (comp b e)))))
+ ((- ,a ,b)
+ (-> (inline 'sub (list (comp a e) (comp b e)))))
+ ((/ ,a ,b)
+ (-> (inline 'div (list (comp a e) (comp b e)))))
+ ((* ,a ,b)
+ (-> (inline 'mul (list (comp a e) (comp b e)))))
+ ((% ,a ,b)
+ (@impl mod (list (comp a e) (comp b e))))
+ ((<< ,a ,b)
+ (@impl shift (list (comp a e) (comp b e))))
+ ((>> ,a ,b)
+ (@impl shift (list (comp a e) (comp `(- ,b) e))))
+ ((< ,a ,b)
+ (-> (inline 'lt? (list (comp a e) (comp b e)))))
+ ((<= ,a ,b)
+ (-> (inline 'le? (list (comp a e) (comp b e)))))
+ ((> ,a ,b)
+ (-> (inline 'gt? (list (comp a e) (comp b e)))))
+ ((>= ,a ,b)
+ (-> (inline 'ge? (list (comp a e) (comp b e)))))
+ ((in ,a ,b)
+ (@impl has-property? (list (comp a e) (comp b e))))
+ ((== ,a ,b)
+ (-> (inline 'equal? (list (comp a e) (comp b e)))))
+ ((!= ,a ,b)
+ (-> (inline 'not
+ (list (-> (inline 'equal?
+ (list (comp a e) (comp b e))))))))
+ ((=== ,a ,b)
+ (-> (inline 'eqv? (list (comp a e) (comp b e)))))
+ ((!== ,a ,b)
+ (-> (inline 'not
+ (list (-> (inline 'eqv?
+ (list (comp a e) (comp b e))))))))
+ ((& ,a ,b)
+ (@impl band (list (comp a e) (comp b e))))
+ ((^ ,a ,b)
+ (@impl bxor (list (comp a e) (comp b e))))
+ ((bor ,a ,b)
+ (@impl bior (list (comp a e) (comp b e))))
+ ((and ,a ,b)
+ (-> (and (list (comp a e) (comp b e)))))
+ ((or ,a ,b)
+ (-> (or (list (comp a e) (comp b e)))))
+ ((if ,test ,then ,else)
+ (-> (if (@impl ->boolean (list (comp test e)))
+ (comp then e)
+ (comp else e))))
+ ((if ,test ,then ,else)
+ (-> (if (@impl ->boolean (list (comp test e)))
+ (comp then e)
+ (@implv *undefined*))))
+ ((postinc (ref ,foo))
+ (begin1 (comp `(ref ,foo) e)
+ (lambda (var)
+ (-> (set (ghil-var-for-set! e foo)
+ (-> (inline 'add
+ (list (-> (ref var))
+ (-> (quote 1))))))))))
+ ((postinc (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (@impl pget
+ (list (-> (ref objvar))
+ (-> (quote prop))))
+ (lambda (tmpvar)
+ (@impl pput
+ (list (-> (ref objvar))
+ (-> (quote prop))
+ (-> (inline 'add
+ (list (-> (ref tmpvar))
+ (-> (quote 1))))))))))))
+ ((postinc (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (@impl pget
+ (list (-> (ref objvar))
+ (-> (ref propvar))))
+ (lambda (tmpvar)
+ (@impl pput
+ (list (-> (ref objvar))
+ (-> (ref propvar))
+ (-> (inline 'add
+ (list (-> (ref tmpvar))
+ (-> (quote 1))))))))))))))
+ ((postdec (ref ,foo))
+ (begin1 (comp `(ref ,foo) e)
+ (lambda (var)
+ (-> (set (ghil-var-for-set! e foo)
+ (-> (inline 'sub
+ (list (-> (ref var))
+ (-> (quote 1))))))))))
+ ((postdec (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (@impl pget
+ (list (-> (ref objvar))
+ (-> (quote prop))))
+ (lambda (tmpvar)
+ (@impl pput
+ (list (-> (ref objvar))
+ (-> (quote prop))
+ (-> (inline 'sub
+ (list (-> (ref tmpvar))
+ (-> (quote 1))))))))))))
+ ((postdec (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (@impl pget
+ (list (-> (ref objvar))
+ (-> (ref propvar))))
+ (lambda (tmpvar)
+ (@impl pput
+ (list (-> (ref objvar))
+ (-> (ref propvar))
+ (-> (inline
+ 'sub (list (-> (ref tmpvar))
+ (-> (quote 1))))))))))))))
+ ((preinc (ref ,foo))
+ (let ((v (ghil-var-for-set! e foo)))
+ (-> (begin
+ (list
+ (-> (set v
+ (-> (inline 'add
+ (list (-> (ref v))
+ (-> (quote 1)))))))
+ (-> (ref v)))))))
+ ((preinc (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (-> (inline 'add
+ (list (@impl pget
+ (list (-> (ref objvar))
+ (-> (quote prop))))
+ (-> (quote 1)))))
+ (lambda (tmpvar)
+ (@impl pput (list (-> (ref objvar))
+ (-> (quote prop))
+ (-> (ref tmpvar)))))))))
+ ((preinc (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (-> (inline 'add
+ (list (@impl pget
+ (list (-> (ref objvar))
+ (-> (ref propvar))))
+ (-> (quote 1)))))
+ (lambda (tmpvar)
+ (@impl pput
+ (list (-> (ref objvar))
+ (-> (ref propvar))
+ (-> (ref tmpvar)))))))))))
+ ((predec (ref ,foo))
+ (let ((v (ghil-var-for-set! e foo)))
+ (-> (begin
+ (list
+ (-> (set v
+ (-> (inline 'sub
+ (list (-> (ref v))
+ (-> (quote 1)))))))
+ (-> (ref v)))))))
+ ((predec (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (-> (inline 'sub
+ (list (@impl pget
+ (list (-> (ref objvar))
+ (-> (quote prop))))
+ (-> (quote 1)))))
+ (lambda (tmpvar)
+ (@impl pput
+ (list (-> (ref objvar))
+ (-> (quote prop))
+ (-> (ref tmpvar)))))))))
+ ((predec (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (-> (inline 'sub
+ (list (@impl pget
+ (list (-> (ref objvar))
+ (-> (ref propvar))))
+ (-> (quote 1)))))
+ (lambda (tmpvar)
+ (@impl pput
+ (list (-> (ref objvar))
+ (-> (ref propvar))
+ (-> (ref tmpvar)))))))))))
+ ((ref ,id)
+ (-> (ref (ghil-var-for-ref! e id))))
+ ((var . ,forms)
+ (-> (begin
+ (map (lambda (form)
+ (pmatch form
+ ((,x ,y)
+ (-> (define (ghil-var-define! (ghil-env-parent e) x)
+ (comp y e))))
+ ((,x)
+ (-> (define (ghil-var-define! (ghil-env-parent e) x)
+ (@implv *undefined*))))
+ (else (error "bad var form" form))))
+ forms))))
+ ((begin . ,forms)
+ (-> (begin
+ (map (lambda (x) (comp x e)) forms))))
+ ((lambda ,formals ,body)
+ (call-with-ghil-environment e '(%args)
+ (lambda (e vars)
+ (-> (lambda vars #t '()
+ (comp-body env l body formals '%args))))))
+ ((call/this ,obj ,prop ,args)
+ (@impl call/this*
+ (list obj
+ (-> (lambda '() #f '()
+ (-> (call (@impl pget (list obj prop))
+ args)))))))
+ ((call (pref ,obj ,prop) ,args)
+ (comp `(call/this ,(comp obj e)
+ ,(-> (quote prop))
+ ,(map (lambda (x) (comp x e)) args))
+ e))
+ ((call (aref ,obj ,prop) ,args)
+ (comp `(call/this ,(comp obj e)
+ ,(comp prop e)
+ ,(map (lambda (x) (comp x e)) args))
+ e))
+ ((call ,proc ,args)
+ (-> (call (comp proc e)
+ (map (lambda (x) (comp x e)) args))))
+ ((return ,expr)
+ (-> (inline 'return
+ (list (comp expr e)))))
+ ((array . ,args)
+ (@impl new-array
+ (map (lambda (x) (comp x e)) args)))
+ ((object . ,args)
+ (@impl new-object
+ (map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (inline 'cons
+ (list (-> (quote prop))
+ (comp val e)))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
+ ((pref ,obj ,prop)
+ (@impl pget
+ (list (comp obj e)
+ (-> (quote prop)))))
+ ((aref ,obj ,index)
+ (@impl pget
+ (list (comp obj e)
+ (comp index e))))
+ ((= (ref ,name) ,val)
+ (let ((v (ghil-var-for-set! e name)))
+ (-> (begin
+ (list (-> (set v (comp val e)))
+ (-> (ref v)))))))
+ ((= (pref ,obj ,prop) ,val)
+ (@impl pput
+ (list (comp obj e)
+ (-> (quote prop))
+ (comp val e))))
+ ((= (aref ,obj ,prop) ,val)
+ (@impl pput
+ (list (comp obj e)
+ (comp prop e)
+ (comp val e))))
+ ((+= ,what ,val)
+ (comp `(= ,what (+ ,what ,val)) e))
+ ((-= ,what ,val)
+ (comp `(= ,what (- ,what ,val)) e))
+ ((/= ,what ,val)
+ (comp `(= ,what (/ ,what ,val)) e))
+ ((*= ,what ,val)
+ (comp `(= ,what (* ,what ,val)) e))
+ ((%= ,what ,val)
+ (comp `(= ,what (% ,what ,val)) e))
+ ((>>= ,what ,val)
+ (comp `(= ,what (>> ,what ,val)) e))
+ ((<<= ,what ,val)
+ (comp `(= ,what (<< ,what ,val)) e))
+ ((>>>= ,what ,val)
+ (comp `(= ,what (>>> ,what ,val)) e))
+ ((&= ,what ,val)
+ (comp `(= ,what (& ,what ,val)) e))
+ ((bor= ,what ,val)
+ (comp `(= ,what (bor ,what ,val)) e))
+ ((^= ,what ,val)
+ (comp `(= ,what (^ ,what ,val)) e))
+ ((new ,what ,args)
+ (@impl new
+ (map (lambda (x) (comp x e))
+ (cons what args))))
+ ((delete (pref ,obj ,prop))
+ (@impl pdel
+ (list (comp obj e)
+ (-> (quote prop)))))
+ ((delete (aref ,obj ,prop))
+ (@impl pdel
+ (list (comp obj e)
+ (comp prop e))))
+ ((void ,expr)
+ (-> (begin
+ (list (comp expr e)
+ (@implv *undefined*)))))
+ ((typeof ,expr)
+ (@impl typeof
+ (list (comp expr e))))
+ ((do ,statement ,test)
+ (call-with-ghil-bindings e '(%loop %continue)
+ (lambda (vars)
+ (-> (bind vars
+ (list (call-with-ghil-environment e '()
+ (lambda (e _)
+ (-> (lambda '() #f '()
+ (-> (begin
+ (list (comp statement e)
+ (-> (call
+ (-> (ref (ghil-var-for-ref! e '%continue)))
+ '())))))))))
+ (call-with-ghil-environment e '()
+ (lambda (e _)
+ (-> (lambda '() #f '()
+ (-> (if (@impl ->boolean (list (comp test e)))
+ (-> (call
+ (-> (ref (ghil-var-for-ref! e '%loop)))
+ '()))
+ (@implv *undefined*))))))))
+ (-> (call (-> (ref (car vars))) '())))))))
+ ((while ,test ,statement)
+ (call-with-ghil-bindings e '(%continue)
+ (lambda (vars)
+ (-> (begin
+ (list
+ (-> (set (car vars)
+ (call-with-ghil-environment e '()
+ (lambda (e _)
+ (-> (lambda '() #f '()
+ (-> (if (@impl ->boolean (list (comp test e)))
+ (-> (begin
+ (list (comp statement e)
+ (-> (call
+ (-> (ref (ghil-var-for-ref! e '%continue)))
+ '())))))
+ (@implv *undefined*)))))))))
+ (-> (call (-> (ref (car vars))) '()))))))))
+ ((for ,init ,test ,inc ,statement)
+ (call-with-ghil-bindings e '(%continue)
+ (lambda (vars)
+ (-> (begin
+ (list
+ (comp (or init '(begin)) e)
+ (-> (set (car vars)
+ (call-with-ghil-environment e '()
+ (lambda (e _)
+ (-> (lambda '() #f '()
+ (-> (if (if test
+ (@impl ->boolean (list (comp test e)))
+ (comp 'true e))
+ (-> (begin
+ (list (comp statement e)
+ (comp (or inc '(begin)) e)
+ (-> (call
+ (-> (ref (ghil-var-for-ref! e '%continue)))
+ '())))))
+ (@implv *undefined*)))))))))
+ (-> (call (-> (ref (car vars))) '()))))))))
+ ((for-in ,var ,object ,statement)
+ (call-with-ghil-bindings e '(%continue %enum)
+ (lambda (vars)
+ (-> (begin
+ (list
+ (-> (set (car vars)
+ (call-with-ghil-environment e '()
+ (lambda (e _)
+ (-> (lambda '() #f '()
+ (-> (if (@impl ->boolean
+ (list (@impl pget
+ (list (-> (ref (ghil-var-for-ref! e '%enum)))
+ (-> (quote 'length))))))
+ (-> (begin
+ (list
+ (comp `(= ,var (call/this ,(-> (ref (ghil-var-for-ref! e '%enum)))
+ ,(-> (quote 'pop))
+ ()))
+ e)
+ (comp statement e)
+ (-> (call (-> (ref (ghil-var-for-ref! e '%continue)))
+ '())))))
+ (@implv *undefined*)))))))))
+ (-> (set (cadr vars)
+ (@impl make-enumerator (list (comp object e)))))
+ (-> (call (-> (ref (car vars))) '()))))))))
+ ((break)
+ (let ((var (ghil-var-for-ref! e '%continue)))
+ (if (and (ghil-env? (ghil-var-env var))
+ (eq? (ghil-var-env var) (ghil-env-parent e)))
+ (-> (inline 'return (@implv *undefined*)))
+ (error "bad break, yo"))))
+ ((continue)
+ (let ((var (ghil-var-for-ref! e '%continue)))
+ (if (and (ghil-env? (ghil-var-env var))
+ (eq? (ghil-var-env var) (ghil-env-parent e)))
+ (-> (inline 'goto/args (list (-> (ref var)))))
+ (error "bad continue, yo"))))
+ ((block ,x)
+ (comp x e))
+ (else
+ (error "compilation not yet implemented:" x)))))
+
+(define (comp-body e l body formals %args)
+ (define (process)
+ (let lp ((in body) (out '()) (rvars (reverse formals)))
+ (pmatch in
+ (((var (,x) . ,morevars) . ,rest)
+ (lp `((var . ,morevars) . ,rest)
+ out
+ (if (memq x rvars) rvars (cons x rvars))))
+ (((var (,x ,y) . ,morevars) . ,rest)
+ (lp `((var . ,morevars) . ,rest)
+ `((= (ref ,x) ,y) . ,out)
+ (if (memq x rvars) rvars (cons x rvars))))
+ (((var) . ,rest)
+ (lp rest out rvars))
+ ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
+ (lp rest
+ (cons x out)
+ rvars))
+ ((,x . ,rest) (guard (pair? x))
+ (receive (sub-out rvars)
+ (lp x '() rvars)
+ (lp rest
+ (cons sub-out out)
+ rvars)))
+ ((,x . ,rest)
+ (lp rest
+ (cons x out)
+ rvars))
+ (()
+ (values (reverse! out)
+ rvars)))))
+ (receive (out rvars)
+ (process)
+ (call-with-ghil-bindings e (reverse rvars)
+ (lambda (vars)
+ (let ((%argv (assq-ref (ghil-env-table e) %args)))
+ (-> (begin
+ `(,@(map
+ (lambda (f)
+ (-> (if (-> (inline 'null?
+ (list (-> (ref %argv)))))
+ (-> (begin '()))
+ (-> (begin
+ (list (-> (set (ghil-var-for-ref! e f)
+ (-> (inline 'car
+ (list (-> (ref %argv)))))))
+ (-> (set %argv
+ (-> (inline 'cdr
+ (list (-> (ref %argv)))))))))))))
+ formals)
+ ;; fixme: here check for too many args
+ ,(comp out e)))))))))
--- /dev/null
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 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 ecmascript function)
+ #:use-module (oop goops)
+ #:use-module (language ecmascript base)
+ #:export (*function-prototype* *program-wrappers*))
+
+
+(define-class <js-program-wrapper> (<js-object>))
+
+(define *program-wrappers* (make-doubly-weak-hash-table 31))
+
+(define *function-prototype* (make <js-object> #:class "Function"
+ #:value (lambda args *undefined*)))
+
+(define-js-method *function-prototype* (toString)
+ (format #f "~A" (js-value this)))
+
+(define-js-method *function-prototype* (apply this-arg array)
+ (cond ((or (null? array) (eq? array *undefined*))
+ (call/this this-arg (js-value this)))
+ ((is-a? array <js-array-object>)
+ (call/this this-arg
+ (lambda ()
+ (apply (js-value this)
+ (vector->list (js-array-vector array))))))
+ (else
+ (throw 'TypeError 'apply array))))
+
+(define-js-method *function-prototype* (call this-arg . args)
+ (call/this this-arg
+ (lambda ()
+ (apply (js-value this) args))))
+
+(define-method (pget (o <applicable>) p)
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (pget wrapper p)
+ (pget *function-prototype* p))))
+
+(define-method (pput (o <applicable>) p v)
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (pput wrapper p v)
+ (let ((wrapper (make <js-program-wrapper> #:value o #:class "Function"
+ #:prototype *function-prototype*)))
+ (hashq-set! *program-wrappers* o wrapper)
+ (pput wrapper p v)))))
+
+(define-method (js-prototype (o <applicable>))
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (js-prototype wrapper)
+ #f)))
+
+(define-method (js-constructor (o <applicable>))
+ (let ((wrapper (hashq-ref *program-wrappers* o)))
+ (if wrapper
+ (js-constructor wrapper)
+ #f)))
--- /dev/null
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 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 ecmascript impl)
+ #:use-module (oop goops)
+ #:use-module (language ecmascript base)
+ #:use-module (language ecmascript function)
+ #:use-module (language ecmascript array)
+ #:re-export (*undefined* *this* call/this*
+ pget pput pdel has-property?
+ ->boolean ->number
+ new-object new new-array)
+ #:export (js-init get-this
+ typeof
+ bitwise-not logical-not
+ shift
+ mod
+ band bxor bior
+ make-enumerator))
+
+
+(define-class <js-module-object> (<js-object>)
+ (module #:init-form (current-module) #:init-keyword #:module
+ #:getter js-module))
+(define-method (pget (o <js-module-object>) (p <string>))
+ (pget o (string->symbol p)))
+(define-method (pget (o <js-module-object>) (p <symbol>))
+ (let ((v (module-variable (js-module o) p)))
+ (if v
+ (variable-ref v)
+ (next-method))))
+(define-method (pput (o <js-module-object>) (p <string>) v)
+ (pput o (string->symbol p) v))
+(define-method (pput (o <js-module-object>) (p <symbol>) v)
+ (module-define! (js-module o) p v))
+(define-method (prop-attrs (o <js-module-object>) (p <symbol>))
+ (cond ((module-local-variable (js-module o) p) '())
+ ((module-variable (js-module o) p) '(DontDelete ReadOnly))
+ (else (next-method))))
+(define-method (prop-attrs (o <js-module-object>) (p <string>))
+ (prop-attrs o (string->symbol p)))
+(define-method (prop-keys (o <js-module-object>))
+ (append (hash-map->list (lambda (k v) k) (module-obarray (js-module o)))
+ (next-method)))
+
+;; we could make a renamer, but having obj['foo-bar'] should be enough
+(define (js-require modstr)
+ (make <js-module-object> #:module
+ (resolve-interface (map string->symbol (string-split modstr #\.)))))
+
+(define-class <js-global-object> (<js-module-object>))
+(define-method (js-module (o <js-global-object>))
+ (current-module))
+
+(define (init-js-bindings! mod)
+ (module-define! mod 'NaN +nan.0)
+ (module-define! mod 'Infinity +inf.0)
+ (module-define! mod 'undefined *undefined*)
+ (module-define! mod 'require js-require)
+ ;; isNAN, isFinite, parseFloat, parseInt, eval
+ ;; decodeURI, decodeURIComponent, encodeURI, encodeURIComponent
+ ;; Object Function Array String Boolean Number Date RegExp Error EvalError
+ ;; RangeError ReferenceError SyntaxError TypeError URIError
+ (module-define! mod 'Object *object-prototype*)
+ (module-define! mod 'Array *array-prototype*))
+
+(define (js-init)
+ (cond ((get-this))
+ (else
+ (fluid-set! *this* (make <js-global-object>))
+ (init-js-bindings! (current-module)))))
+
+(define (get-this)
+ (fluid-ref *this*))
+
+(define (typeof x)
+ (cond ((eq? x *undefined*) "undefined")
+ ((null? x) "object")
+ ((boolean? x) "boolean")
+ ((number? x) "number")
+ ((string? x) "string")
+ ((procedure? x) "function")
+ ((is-a? x <js-object>) "object")
+ (else "scm")))
+
+(define bitwise-not lognot)
+(define (logical-not x)
+ (not (->boolean (->primitive x))))
+
+(define shift ash)
+
+(define band logand)
+(define bxor logxor)
+(define bior logior)
+
+(define mod modulo)
+
+(define-method (+ (a <string>) (b <string>))
+ (string-append a b))
+
+(define-method (+ (a <string>) b)
+ (string-append a (->string b)))
+
+(define-method (+ a (b <string>))
+ (string-append (->string a) b))
+
+(define-method (+ a b)
+ (+ (->number a) (->number b)))
+
+(define-method (- a b)
+ (- (->number a) (->number b)))
+
+(define-method (* a b)
+ (* (->number a) (->number b)))
+
+(define-method (/ a b)
+ (/ (->number a) (->number b)))
+
+(define-method (< a b)
+ (< (->number a) (->number b)))
+(define-method (< (a <string>) (b <string>))
+ (string< a b))
+
+(define-method (<= a b)
+ (<= (->number a) (->number b)))
+(define-method (<= (a <string>) (b <string>))
+ (string<= a b))
+
+(define-method (>= a b)
+ (>= (->number a) (->number b)))
+(define-method (>= (a <string>) (b <string>))
+ (string>= a b))
+
+(define-method (> a b)
+ (> (->number a) (->number b)))
+(define-method (> (a <string>) (b <string>))
+ (string> a b))
+
+(define (obj-and-prototypes o)
+ (if o
+ (cons o (obj-and-prototypes (js-prototype o)))
+ '()))
+
+(define (make-enumerator obj)
+ (let ((props (make-hash-table 23)))
+ (for-each (lambda (o)
+ (for-each (lambda (k) (hashq-set! props k #t))
+ (prop-keys o)))
+ (obj-and-prototypes obj))
+ (apply new-array (filter (lambda (p)
+ (not (prop-has-attr? obj p 'DontEnum)))
+ (hash-map->list (lambda (k v) k) props)))))
--- /dev/null
+;; (language ecmascript parse-lalr) -- yacc's parser generator, in Guile
+;; Copyright (C) 1984,1989,1990 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2002 Dominique Boucher
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 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, see <http://www.gnu.org/licenses/>.
+
+
+;; ---------------------------------------------------------------------- ;;
+#!
+;;; Commentary:
+This file contains yet another LALR(1) parser generator written in
+Scheme. In contrast to other such parser generators, this one
+implements a more efficient algorithm for computing the lookahead sets.
+The algorithm is the same as used in Bison (GNU yacc) and is described
+in the following paper:
+
+"Efficient Computation of LALR(1) Look-Ahead Set", F. DeRemer and
+T. Pennello, TOPLAS, vol. 4, no. 4, october 1982.
+
+As a consequence, it is not written in a fully functional style.
+In fact, much of the code is a direct translation from C to Scheme
+of the Bison sources.
+
+@section Defining a parser
+
+The module @code{(language ecmascript parse-lalr)} declares a macro
+called @code{lalr-parser}:
+
+@lisp
+ (lalr-parser tokens rules ...)
+@end lisp
+
+This macro, when given appropriate arguments, generates an LALR(1)
+syntax analyzer. The macro accepts at least two arguments. The first
+is a list of symbols which represent the terminal symbols of the
+grammar. The remaining arguments are the grammar production rules.
+
+@section Running the parser
+
+The parser generated by the @code{lalr-parser} macro is a function that
+takes two parameters. The first parameter is a lexical analyzer while
+the second is an error procedure.
+
+The lexical analyzer is zero-argument function (a thunk)
+invoked each time the parser needs to look-ahead in the token stream.
+A token is usually a pair whose @code{car} is the symbol corresponding to
+the token (the same symbol as used in the grammar definition). The
+@code{cdr} of the pair is the semantic value associated with the token. For
+example, a string token would have the @code{car} set to @code{'string}
+while the @code{cdr} is set to the string value @code{"hello"}.
+
+Once the end of file is encountered, the lexical analyzer must always
+return the symbol @code{'*eoi*} each time it is invoked.
+
+The error procedure must be a function that accepts at least two
+parameters.
+
+@section The grammar format
+
+The grammar is specified by first giving the list of terminals and the
+list of non-terminal definitions. Each non-terminal definition
+is a list where the first element is the non-terminal and the other
+elements are the right-hand sides (lists of grammar symbols). In
+addition to this, each rhs can be followed by a semantic action.
+
+For example, consider the following (yacc) grammar for a very simple
+expression language:
+@example
+ e : e '+' t
+ | e '-' t
+ | t
+ ;
+ t : t '*' f
+ : t '/' f
+ | f
+ ;
+ f : ID
+ ;
+@end example
+The same grammar, written for the scheme parser generator, would look
+like this (with semantic actions)
+@lisp
+(define expr-parser
+ (lalr-parser
+ ; Terminal symbols
+ (ID + - * /)
+ ; Productions
+ (e (e + t) -> (+ $1 $3)
+ (e - t) -> (- $1 $3)
+ (t) -> $1)
+ (t (t * f) -> (* $1 $3)
+ (t / f) -> (/ $1 $3)
+ (f) -> $1)
+ (f (ID) -> $1)))
+@end lisp
+In semantic actions, the symbol @code{$n} refers to the synthesized
+attribute value of the nth symbol in the production. The value
+associated with the non-terminal on the left is the result of
+evaluating the semantic action (it defaults to @code{#f}).
+
+The above grammar implicitly handles operator precedences. It is also
+possible to explicitly assign precedences and associativity to
+terminal symbols and productions a la Yacc. Here is a modified
+(and augmented) version of the grammar:
+@lisp
+(define expr-parser
+ (lalr-parser
+ ; Terminal symbols
+ (ID
+ (left: + -)
+ (left: * /)
+ (nonassoc: uminus))
+ (e (e + e) -> (+ $1 $3)
+ (e - e) -> (- $1 $3)
+ (e * e) -> (* $1 $3)
+ (e / e) -> (/ $1 $3)
+ (- e (prec: uminus)) -> (- $2)
+ (ID) -> $1)))
+@end lisp
+The @code{left:} directive is used to specify a set of left-associative
+operators of the same precedence level, the @code{right:} directive for
+right-associative operators, and @code{nonassoc:} for operators that
+are not associative. Note the use of the (apparently) useless
+terminal @code{uminus}. It is only defined in order to assign to the
+penultimate rule a precedence level higher than that of @code{*} and
+@code{/}. The @code{prec:} directive can only appear as the last element of a
+rule. Finally, note that precedence levels are incremented from
+left to right, i.e. the precedence level of @code{+} and @code{-} is less
+than the precedence level of @code{*} and @code{/} since the formers appear
+first in the list of terminal symbols (token definitions).
+
+@section A final note on conflict resolution
+
+Conflicts in the grammar are handled in a conventional way.
+In the absence of precedence directives,
+Shift/Reduce conflicts are resolved by shifting, and Reduce/Reduce
+conflicts are resolved by choosing the rule listed first in the
+grammar definition.
+
+You can print the states of the generated parser by evaluating
+@code{(print-states)}. The format of the output is similar to the one
+produced by bison when given the -v command-line option.
+;;; Code:
+!#
+
+;;; ---------- SYSTEM DEPENDENT SECTION -----------------
+;; put in a module by Richard Todd
+(define-module (language ecmascript parse-lalr)
+ #:export (lalr-parser
+ print-states))
+
+;; this code is by Thien-Thi Nguyen, found in a google search
+(begin
+ (defmacro def-macro (form . body)
+ `(defmacro ,(car form) ,(cdr form) ,@body))
+ (def-macro (BITS-PER-WORD) 28)
+ (def-macro (lalr-error msg obj) `(throw 'lalr-error ,msg ,obj))
+ (def-macro (logical-or x . y) `(logior ,x ,@y)))
+
+;;; ---------- END OF SYSTEM DEPENDENT SECTION ------------
+
+;; - Macros pour la gestion des vecteurs de bits
+
+(def-macro (set-bit v b)
+ `(let ((x (quotient ,b (BITS-PER-WORD)))
+ (y (expt 2 (remainder ,b (BITS-PER-WORD)))))
+ (vector-set! ,v x (logical-or (vector-ref ,v x) y))))
+
+(def-macro (bit-union v1 v2 n)
+ `(do ((i 0 (+ i 1)))
+ ((= i ,n))
+ (vector-set! ,v1 i (logical-or (vector-ref ,v1 i)
+ (vector-ref ,v2 i)))))
+
+;; - Macro pour les structures de donnees
+
+(def-macro (new-core) `(make-vector 4 0))
+(def-macro (set-core-number! c n) `(vector-set! ,c 0 ,n))
+(def-macro (set-core-acc-sym! c s) `(vector-set! ,c 1 ,s))
+(def-macro (set-core-nitems! c n) `(vector-set! ,c 2 ,n))
+(def-macro (set-core-items! c i) `(vector-set! ,c 3 ,i))
+(def-macro (core-number c) `(vector-ref ,c 0))
+(def-macro (core-acc-sym c) `(vector-ref ,c 1))
+(def-macro (core-nitems c) `(vector-ref ,c 2))
+(def-macro (core-items c) `(vector-ref ,c 3))
+
+(def-macro (new-shift) `(make-vector 3 0))
+(def-macro (set-shift-number! c x) `(vector-set! ,c 0 ,x))
+(def-macro (set-shift-nshifts! c x) `(vector-set! ,c 1 ,x))
+(def-macro (set-shift-shifts! c x) `(vector-set! ,c 2 ,x))
+(def-macro (shift-number s) `(vector-ref ,s 0))
+(def-macro (shift-nshifts s) `(vector-ref ,s 1))
+(def-macro (shift-shifts s) `(vector-ref ,s 2))
+
+(def-macro (new-red) `(make-vector 3 0))
+(def-macro (set-red-number! c x) `(vector-set! ,c 0 ,x))
+(def-macro (set-red-nreds! c x) `(vector-set! ,c 1 ,x))
+(def-macro (set-red-rules! c x) `(vector-set! ,c 2 ,x))
+(def-macro (red-number c) `(vector-ref ,c 0))
+(def-macro (red-nreds c) `(vector-ref ,c 1))
+(def-macro (red-rules c) `(vector-ref ,c 2))
+
+
+
+(def-macro (new-set nelem)
+ `(make-vector ,nelem 0))
+
+
+(def-macro (vector-map f v)
+ `(let ((vm-n (- (vector-length ,v) 1)))
+ (let loop ((vm-low 0) (vm-high vm-n))
+ (if (= vm-low vm-high)
+ (vector-set! ,v vm-low (,f (vector-ref ,v vm-low) vm-low))
+ (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
+ (loop vm-low vm-middle)
+ (loop (+ vm-middle 1) vm-high))))))
+
+
+;; - Constantes
+(define STATE-TABLE-SIZE 1009)
+
+
+;; - Tableaux
+(define rrhs #f)
+(define rlhs #f)
+(define ritem #f)
+(define nullable #f)
+(define derives #f)
+(define fderives #f)
+(define firsts #f)
+(define kernel-base #f)
+(define kernel-end #f)
+(define shift-symbol #f)
+(define shift-set #f)
+(define red-set #f)
+(define state-table #f)
+(define acces-symbol #f)
+(define reduction-table #f)
+(define shift-table #f)
+(define consistent #f)
+(define lookaheads #f)
+(define LA #f)
+(define LAruleno #f)
+(define lookback #f)
+(define goto-map #f)
+(define from-state #f)
+(define to-state #f)
+(define includes #f)
+(define F #f)
+(define action-table #f)
+
+;; - Variables
+(define nitems #f)
+(define nrules #f)
+(define nvars #f)
+(define nterms #f)
+(define nsyms #f)
+(define nstates #f)
+(define first-state #f)
+(define last-state #f)
+(define final-state #f)
+(define first-shift #f)
+(define last-shift #f)
+(define first-reduction #f)
+(define last-reduction #f)
+(define nshifts #f)
+(define maxrhs #f)
+(define ngotos #f)
+(define token-set-size #f)
+
+(define (gen-tables! tokens gram)
+ (initialize-all)
+ (rewrite-grammar
+ tokens
+ gram
+ (lambda (terms terms/prec vars gram gram/actions)
+ (set! the-terminals/prec (list->vector terms/prec))
+ (set! the-terminals (list->vector terms))
+ (set! the-nonterminals (list->vector vars))
+ (set! nterms (length terms))
+ (set! nvars (length vars))
+ (set! nsyms (+ nterms nvars))
+ (let ((no-of-rules (length gram/actions))
+ (no-of-items (let loop ((l gram/actions) (count 0))
+ (if (null? l)
+ count
+ (loop (cdr l) (+ count (length (caar l))))))))
+ (pack-grammar no-of-rules no-of-items gram)
+ (set-derives)
+ (set-nullable)
+ (generate-states)
+ (lalr)
+ (build-tables)
+ (compact-action-table terms)
+ gram/actions))))
+
+
+(define (initialize-all)
+ (set! rrhs #f)
+ (set! rlhs #f)
+ (set! ritem #f)
+ (set! nullable #f)
+ (set! derives #f)
+ (set! fderives #f)
+ (set! firsts #f)
+ (set! kernel-base #f)
+ (set! kernel-end #f)
+ (set! shift-symbol #f)
+ (set! shift-set #f)
+ (set! red-set #f)
+ (set! state-table (make-vector STATE-TABLE-SIZE '()))
+ (set! acces-symbol #f)
+ (set! reduction-table #f)
+ (set! shift-table #f)
+ (set! consistent #f)
+ (set! lookaheads #f)
+ (set! LA #f)
+ (set! LAruleno #f)
+ (set! lookback #f)
+ (set! goto-map #f)
+ (set! from-state #f)
+ (set! to-state #f)
+ (set! includes #f)
+ (set! F #f)
+ (set! action-table #f)
+ (set! nstates #f)
+ (set! first-state #f)
+ (set! last-state #f)
+ (set! final-state #f)
+ (set! first-shift #f)
+ (set! last-shift #f)
+ (set! first-reduction #f)
+ (set! last-reduction #f)
+ (set! nshifts #f)
+ (set! maxrhs #f)
+ (set! ngotos #f)
+ (set! token-set-size #f)
+ (set! rule-precedences '()))
+
+
+(define (pack-grammar no-of-rules no-of-items gram)
+ (set! nrules (+ no-of-rules 1))
+ (set! nitems no-of-items)
+ (set! rlhs (make-vector nrules #f))
+ (set! rrhs (make-vector nrules #f))
+ (set! ritem (make-vector (+ 1 nitems) #f))
+
+ (let loop ((p gram) (item-no 0) (rule-no 1))
+ (if (not (null? p))
+ (let ((nt (caar p)))
+ (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
+ (if (null? prods)
+ (loop (cdr p) it-no2 rl-no2)
+ (begin
+ (vector-set! rlhs rl-no2 nt)
+ (vector-set! rrhs rl-no2 it-no2)
+ (let loop3 ((rhs (car prods)) (it-no3 it-no2))
+ (if (null? rhs)
+ (begin
+ (vector-set! ritem it-no3 (- rl-no2))
+ (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
+ (begin
+ (vector-set! ritem it-no3 (car rhs))
+ (loop3 (cdr rhs) (+ it-no3 1))))))))))))
+
+
+;; Fonction set-derives
+;; --------------------
+(define (set-derives)
+ (define delts (make-vector (+ nrules 1) 0))
+ (define dset (make-vector nvars -1))
+
+ (let loop ((i 1) (j 0)) ; i = 0
+ (if (< i nrules)
+ (let ((lhs (vector-ref rlhs i)))
+ (if (>= lhs 0)
+ (begin
+ (vector-set! delts j (cons i (vector-ref dset lhs)))
+ (vector-set! dset lhs j)
+ (loop (+ i 1) (+ j 1)))
+ (loop (+ i 1) j)))))
+
+ (set! derives (make-vector nvars 0))
+
+ (let loop ((i 0))
+ (if (< i nvars)
+ (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
+ (if (< j 0)
+ s
+ (let ((x (vector-ref delts j)))
+ (loop2 (cdr x) (cons (car x) s)))))))
+ (vector-set! derives i q)
+ (loop (+ i 1))))))
+
+
+
+(define (set-nullable)
+ (set! nullable (make-vector nvars #f))
+ (let ((squeue (make-vector nvars #f))
+ (rcount (make-vector (+ nrules 1) 0))
+ (rsets (make-vector nvars #f))
+ (relts (make-vector (+ nitems nvars 1) #f)))
+ (let loop ((r 0) (s2 0) (p 0))
+ (let ((*r (vector-ref ritem r)))
+ (if *r
+ (if (< *r 0)
+ (let ((symbol (vector-ref rlhs (- *r))))
+ (if (and (>= symbol 0)
+ (not (vector-ref nullable symbol)))
+ (begin
+ (vector-set! nullable symbol #t)
+ (vector-set! squeue s2 symbol)
+ (loop (+ r 1) (+ s2 1) p))))
+ (let loop2 ((r1 r) (any-tokens #f))
+ (let* ((symbol (vector-ref ritem r1)))
+ (if (> symbol 0)
+ (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
+ (if (not any-tokens)
+ (let ((ruleno (- symbol)))
+ (let loop3 ((r2 r) (p2 p))
+ (let ((symbol (vector-ref ritem r2)))
+ (if (> symbol 0)
+ (begin
+ (vector-set! rcount ruleno
+ (+ (vector-ref rcount ruleno) 1))
+ (vector-set! relts p2
+ (cons (vector-ref rsets symbol)
+ ruleno))
+ (vector-set! rsets symbol p2)
+ (loop3 (+ r2 1) (+ p2 1)))
+ (loop (+ r2 1) s2 p2)))))
+ (loop (+ r1 1) s2 p))))))
+ (let loop ((s1 0) (s3 s2))
+ (if (< s1 s3)
+ (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
+ (if p
+ (let* ((x (vector-ref relts p))
+ (ruleno (cdr x))
+ (y (- (vector-ref rcount ruleno) 1)))
+ (vector-set! rcount ruleno y)
+ (if (= y 0)
+ (let ((symbol (vector-ref rlhs ruleno)))
+ (if (and (>= symbol 0)
+ (not (vector-ref nullable symbol)))
+ (begin
+ (vector-set! nullable symbol #t)
+ (vector-set! squeue s4 symbol)
+ (loop2 (car x) (+ s4 1)))
+ (loop2 (car x) s4)))
+ (loop2 (car x) s4))))
+ (loop (+ s1 1) s4)))))))))
+
+
+
+; Fonction set-firsts qui calcule un tableau de taille
+; nvars et qui donne, pour chaque non-terminal X, une liste des
+; non-terminaux pouvant apparaitre au debut d'une derivation a
+; partir de X.
+
+(define (set-firsts)
+ (set! firsts (make-vector nvars '()))
+
+ ;; -- initialization
+ (let loop ((i 0))
+ (if (< i nvars)
+ (let loop2 ((sp (vector-ref derives i)))
+ (if (null? sp)
+ (loop (+ i 1))
+ (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
+ (if (< -1 sym nvars)
+ (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
+ (loop2 (cdr sp)))))))
+
+ ;; -- reflexive and transitive closure
+ (let loop ((continue #t))
+ (if continue
+ (let loop2 ((i 0) (cont #f))
+ (if (>= i nvars)
+ (loop cont)
+ (let* ((x (vector-ref firsts i))
+ (y (let loop3 ((l x) (z x))
+ (if (null? l)
+ z
+ (loop3 (cdr l)
+ (sunion (vector-ref firsts (car l)) z))))))
+ (if (equal? x y)
+ (loop2 (+ i 1) cont)
+ (begin
+ (vector-set! firsts i y)
+ (loop2 (+ i 1) #t))))))))
+
+ (let loop ((i 0))
+ (if (< i nvars)
+ (begin
+ (vector-set! firsts i (sinsert i (vector-ref firsts i)))
+ (loop (+ i 1))))))
+
+
+
+
+; Fonction set-fderives qui calcule un tableau de taille
+; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant
+; etre derivees a partir de ce non-terminal. (se sert de firsts)
+
+(define (set-fderives)
+ (set! fderives (make-vector nvars #f))
+
+ (set-firsts)
+
+ (let loop ((i 0))
+ (if (< i nvars)
+ (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
+ (if (null? l)
+ fd
+ (loop2 (cdr l)
+ (sunion (vector-ref derives (car l)) fd))))))
+ (vector-set! fderives i x)
+ (loop (+ i 1))))))
+
+
+; Fonction calculant la fermeture d'un ensemble d'items LR0
+; ou core est une liste d'items
+
+(define (closure core)
+ ;; Initialization
+ (define ruleset (make-vector nrules #f))
+
+ (let loop ((csp core))
+ (if (not (null? csp))
+ (let ((sym (vector-ref ritem (car csp))))
+ (if (< -1 sym nvars)
+ (let loop2 ((dsp (vector-ref fderives sym)))
+ (if (not (null? dsp))
+ (begin
+ (vector-set! ruleset (car dsp) #t)
+ (loop2 (cdr dsp))))))
+ (loop (cdr csp)))))
+
+ (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
+ (if (< ruleno nrules)
+ (if (vector-ref ruleset ruleno)
+ (let ((itemno (vector-ref rrhs ruleno)))
+ (let loop2 ((c csp) (itemsetv2 itemsetv))
+ (if (and (pair? c)
+ (< (car c) itemno))
+ (loop2 (cdr c) (cons (car c) itemsetv2))
+ (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
+ (loop (+ ruleno 1) csp itemsetv))
+ (let loop2 ((c csp) (itemsetv2 itemsetv))
+ (if (pair? c)
+ (loop2 (cdr c) (cons (car c) itemsetv2))
+ (reverse itemsetv2))))))
+
+
+
+(define (allocate-item-sets)
+ (set! kernel-base (make-vector nsyms 0))
+ (set! kernel-end (make-vector nsyms #f)))
+
+
+(define (allocate-storage)
+ (allocate-item-sets)
+ (set! red-set (make-vector (+ nrules 1) 0)))
+
+;; --
+
+
+(define (initialize-states)
+ (let ((p (new-core)))
+ (set-core-number! p 0)
+ (set-core-acc-sym! p #f)
+ (set-core-nitems! p 1)
+ (set-core-items! p '(0))
+
+ (set! first-state (list p))
+ (set! last-state first-state)
+ (set! nstates 1)))
+
+
+
+(define (generate-states)
+ (allocate-storage)
+ (set-fderives)
+ (initialize-states)
+ (let loop ((this-state first-state))
+ (if (pair? this-state)
+ (let* ((x (car this-state))
+ (is (closure (core-items x))))
+ (save-reductions x is)
+ (new-itemsets is)
+ (append-states)
+ (if (> nshifts 0)
+ (save-shifts x))
+ (loop (cdr this-state))))))
+
+
+;; Fonction calculant les symboles sur lesquels il faut "shifter"
+;; et regroupe les items en fonction de ces symboles
+
+(define (new-itemsets itemset)
+ ;; - Initialization
+ (set! shift-symbol '())
+ (let loop ((i 0))
+ (if (< i nsyms)
+ (begin
+ (vector-set! kernel-end i '())
+ (loop (+ i 1)))))
+
+ (let loop ((isp itemset))
+ (if (pair? isp)
+ (let* ((i (car isp))
+ (sym (vector-ref ritem i)))
+ (if (>= sym 0)
+ (begin
+ (set! shift-symbol (sinsert sym shift-symbol))
+ (let ((x (vector-ref kernel-end sym)))
+ (if (null? x)
+ (begin
+ (vector-set! kernel-base sym (cons (+ i 1) x))
+ (vector-set! kernel-end sym (vector-ref kernel-base sym)))
+ (begin
+ (set-cdr! x (list (+ i 1)))
+ (vector-set! kernel-end sym (cdr x)))))))
+ (loop (cdr isp)))))
+
+ (set! nshifts (length shift-symbol)))
+
+
+
+(define (get-state sym)
+ (let* ((isp (vector-ref kernel-base sym))
+ (n (length isp))
+ (key (let loop ((isp1 isp) (k 0))
+ (if (null? isp1)
+ (modulo k STATE-TABLE-SIZE)
+ (loop (cdr isp1) (+ k (car isp1))))))
+ (sp (vector-ref state-table key)))
+ (if (null? sp)
+ (let ((x (new-state sym)))
+ (vector-set! state-table key (list x))
+ (core-number x))
+ (let loop ((sp1 sp))
+ (if (and (= n (core-nitems (car sp1)))
+ (let loop2 ((i1 isp) (t (core-items (car sp1))))
+ (if (and (pair? i1)
+ (= (car i1)
+ (car t)))
+ (loop2 (cdr i1) (cdr t))
+ (null? i1))))
+ (core-number (car sp1))
+ (if (null? (cdr sp1))
+ (let ((x (new-state sym)))
+ (set-cdr! sp1 (list x))
+ (core-number x))
+ (loop (cdr sp1))))))))
+
+
+(define (new-state sym)
+ (let* ((isp (vector-ref kernel-base sym))
+ (n (length isp))
+ (p (new-core)))
+ (set-core-number! p nstates)
+ (set-core-acc-sym! p sym)
+ (if (= sym nvars) (set! final-state nstates))
+ (set-core-nitems! p n)
+ (set-core-items! p isp)
+ (set-cdr! last-state (list p))
+ (set! last-state (cdr last-state))
+ (set! nstates (+ nstates 1))
+ p))
+
+
+;; --
+
+(define (append-states)
+ (set! shift-set
+ (let loop ((l (reverse shift-symbol)))
+ (if (null? l)
+ '()
+ (cons (get-state (car l)) (loop (cdr l)))))))
+
+;; --
+
+(define (save-shifts core)
+ (let ((p (new-shift)))
+ (set-shift-number! p (core-number core))
+ (set-shift-nshifts! p nshifts)
+ (set-shift-shifts! p shift-set)
+ (if last-shift
+ (begin
+ (set-cdr! last-shift (list p))
+ (set! last-shift (cdr last-shift)))
+ (begin
+ (set! first-shift (list p))
+ (set! last-shift first-shift)))))
+
+(define (save-reductions core itemset)
+ (let ((rs (let loop ((l itemset))
+ (if (null? l)
+ '()
+ (let ((item (vector-ref ritem (car l))))
+ (if (< item 0)
+ (cons (- item) (loop (cdr l)))
+ (loop (cdr l))))))))
+ (if (pair? rs)
+ (let ((p (new-red)))
+ (set-red-number! p (core-number core))
+ (set-red-nreds! p (length rs))
+ (set-red-rules! p rs)
+ (if last-reduction
+ (begin
+ (set-cdr! last-reduction (list p))
+ (set! last-reduction (cdr last-reduction)))
+ (begin
+ (set! first-reduction (list p))
+ (set! last-reduction first-reduction)))))))
+
+
+;; --
+
+(define (lalr)
+ (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
+ (set-accessing-symbol)
+ (set-shift-table)
+ (set-reduction-table)
+ (set-max-rhs)
+ (initialize-LA)
+ (set-goto-map)
+ (initialize-F)
+ (build-relations)
+ (digraph includes)
+ (compute-lookaheads))
+
+(define (set-accessing-symbol)
+ (set! acces-symbol (make-vector nstates #f))
+ (let loop ((l first-state))
+ (if (pair? l)
+ (let ((x (car l)))
+ (vector-set! acces-symbol (core-number x) (core-acc-sym x))
+ (loop (cdr l))))))
+
+(define (set-shift-table)
+ (set! shift-table (make-vector nstates #f))
+ (let loop ((l first-shift))
+ (if (pair? l)
+ (let ((x (car l)))
+ (vector-set! shift-table (shift-number x) x)
+ (loop (cdr l))))))
+
+(define (set-reduction-table)
+ (set! reduction-table (make-vector nstates #f))
+ (let loop ((l first-reduction))
+ (if (pair? l)
+ (let ((x (car l)))
+ (vector-set! reduction-table (red-number x) x)
+ (loop (cdr l))))))
+
+(define (set-max-rhs)
+ (let loop ((p 0) (curmax 0) (length 0))
+ (let ((x (vector-ref ritem p)))
+ (if x
+ (if (>= x 0)
+ (loop (+ p 1) curmax (+ length 1))
+ (loop (+ p 1) (max curmax length) 0))
+ (set! maxrhs curmax)))))
+
+(define (initialize-LA)
+ (define (last l)
+ (if (null? (cdr l))
+ (car l)
+ (last (cdr l))))
+
+ (set! consistent (make-vector nstates #f))
+ (set! lookaheads (make-vector (+ nstates 1) #f))
+
+ (let loop ((count 0) (i 0))
+ (if (< i nstates)
+ (begin
+ (vector-set! lookaheads i count)
+ (let ((rp (vector-ref reduction-table i))
+ (sp (vector-ref shift-table i)))
+ (if (and rp
+ (or (> (red-nreds rp) 1)
+ (and sp
+ (not
+ (< (vector-ref acces-symbol
+ (last (shift-shifts sp)))
+ nvars)))))
+ (loop (+ count (red-nreds rp)) (+ i 1))
+ (begin
+ (vector-set! consistent i #t)
+ (loop count (+ i 1))))))
+
+ (begin
+ (vector-set! lookaheads nstates count)
+ (let ((c (max count 1)))
+ (set! LA (make-vector c #f))
+ (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
+ (set! LAruleno (make-vector c -1))
+ (set! lookback (make-vector c #f)))
+ (let loop ((i 0) (np 0))
+ (if (< i nstates)
+ (if (vector-ref consistent i)
+ (loop (+ i 1) np)
+ (let ((rp (vector-ref reduction-table i)))
+ (if rp
+ (let loop2 ((j (red-rules rp)) (np2 np))
+ (if (null? j)
+ (loop (+ i 1) np2)
+ (begin
+ (vector-set! LAruleno np2 (car j))
+ (loop2 (cdr j) (+ np2 1)))))
+ (loop (+ i 1) np))))))))))
+
+
+(define (set-goto-map)
+ (set! goto-map (make-vector (+ nvars 1) 0))
+ (let ((temp-map (make-vector (+ nvars 1) 0)))
+ (let loop ((ng 0) (sp first-shift))
+ (if (pair? sp)
+ (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
+ (if (pair? i)
+ (let ((symbol (vector-ref acces-symbol (car i))))
+ (if (< symbol nvars)
+ (begin
+ (vector-set! goto-map symbol
+ (+ 1 (vector-ref goto-map symbol)))
+ (loop2 (cdr i) (+ ng2 1)))
+ (loop2 (cdr i) ng2)))
+ (loop ng2 (cdr sp))))
+
+ (let loop ((k 0) (i 0))
+ (if (< i nvars)
+ (begin
+ (vector-set! temp-map i k)
+ (loop (+ k (vector-ref goto-map i)) (+ i 1)))
+
+ (begin
+ (do ((i 0 (+ i 1)))
+ ((>= i nvars))
+ (vector-set! goto-map i (vector-ref temp-map i)))
+
+ (set! ngotos ng)
+ (vector-set! goto-map nvars ngotos)
+ (vector-set! temp-map nvars ngotos)
+ (set! from-state (make-vector ngotos #f))
+ (set! to-state (make-vector ngotos #f))
+
+ (do ((sp first-shift (cdr sp)))
+ ((null? sp))
+ (let* ((x (car sp))
+ (state1 (shift-number x)))
+ (do ((i (shift-shifts x) (cdr i)))
+ ((null? i))
+ (let* ((state2 (car i))
+ (symbol (vector-ref acces-symbol state2)))
+ (if (< symbol nvars)
+ (let ((k (vector-ref temp-map symbol)))
+ (vector-set! temp-map symbol (+ k 1))
+ (vector-set! from-state k state1)
+ (vector-set! to-state k state2))))))))))))))
+
+
+(define (map-goto state symbol)
+ (let loop ((low (vector-ref goto-map symbol))
+ (high (- (vector-ref goto-map (+ symbol 1)) 1)))
+ (if (> low high)
+ (begin
+ (display (list "Error in map-goto" state symbol) (current-error-port))
+ (newline (current-error-port))
+ 0)
+ (let* ((middle (quotient (+ low high) 2))
+ (s (vector-ref from-state middle)))
+ (cond
+ ((= s state)
+ middle)
+ ((< s state)
+ (loop (+ middle 1) high))
+ (else
+ (loop low (- middle 1))))))))
+
+
+(define (initialize-F)
+ (set! F (make-vector ngotos #f))
+ (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
+
+ (let ((reads (make-vector ngotos #f)))
+
+ (let loop ((i 0) (rowp 0))
+ (if (< i ngotos)
+ (let* ((rowf (vector-ref F rowp))
+ (stateno (vector-ref to-state i))
+ (sp (vector-ref shift-table stateno)))
+ (if sp
+ (let loop2 ((j (shift-shifts sp)) (edges '()))
+ (if (pair? j)
+ (let ((symbol (vector-ref acces-symbol (car j))))
+ (if (< symbol nvars)
+ (if (vector-ref nullable symbol)
+ (loop2 (cdr j) (cons (map-goto stateno symbol)
+ edges))
+ (loop2 (cdr j) edges))
+ (begin
+ (set-bit rowf (- symbol nvars))
+ (loop2 (cdr j) edges))))
+ (if (pair? edges)
+ (vector-set! reads i (reverse edges))))))
+ (loop (+ i 1) (+ rowp 1)))))
+ (digraph reads)))
+
+(define (add-lookback-edge stateno ruleno gotono)
+ (let ((k (vector-ref lookaheads (+ stateno 1))))
+ (let loop ((found #f) (i (vector-ref lookaheads stateno)))
+ (if (and (not found) (< i k))
+ (if (= (vector-ref LAruleno i) ruleno)
+ (loop #t i)
+ (loop found (+ i 1)))
+
+ (if (not found)
+ (begin (display "Error in add-lookback-edge : " (current-error-port))
+ (display (list stateno ruleno gotono) (current-error-port))
+ (newline (current-error-port)))
+ (vector-set! lookback i
+ (cons gotono (vector-ref lookback i))))))))
+
+
+(define (transpose r-arg n)
+ (let ((new-end (make-vector n #f))
+ (new-R (make-vector n #f)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (let ((x (list 'bidon)))
+ (vector-set! new-R i x)
+ (vector-set! new-end i x)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (let ((sp (vector-ref r-arg i)))
+ (if (pair? sp)
+ (let loop ((sp2 sp))
+ (if (pair? sp2)
+ (let* ((x (car sp2))
+ (y (vector-ref new-end x)))
+ (set-cdr! y (cons i (cdr y)))
+ (vector-set! new-end x (cdr y))
+ (loop (cdr sp2))))))))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (vector-set! new-R i (cdr (vector-ref new-R i))))
+
+ new-R))
+
+
+
+(define (build-relations)
+
+ (define (get-state stateno symbol)
+ (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
+ (stno stateno))
+ (if (null? j)
+ stno
+ (let ((st2 (car j)))
+ (if (= (vector-ref acces-symbol st2) symbol)
+ st2
+ (loop (cdr j) st2))))))
+
+ (set! includes (make-vector ngotos #f))
+ (do ((i 0 (+ i 1)))
+ ((= i ngotos))
+ (let ((state1 (vector-ref from-state i))
+ (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
+ (let loop ((rulep (vector-ref derives symbol1))
+ (edges '()))
+ (if (pair? rulep)
+ (let ((*rulep (car rulep)))
+ (let loop2 ((rp (vector-ref rrhs *rulep))
+ (stateno state1)
+ (states (list state1)))
+ (let ((*rp (vector-ref ritem rp)))
+ (if (> *rp 0)
+ (let ((st (get-state stateno *rp)))
+ (loop2 (+ rp 1) st (cons st states)))
+ (begin
+
+ (if (not (vector-ref consistent stateno))
+ (add-lookback-edge stateno *rulep i))
+
+ (let loop2 ((done #f)
+ (stp (cdr states))
+ (rp2 (- rp 1))
+ (edgp edges))
+ (if (not done)
+ (let ((*rp (vector-ref ritem rp2)))
+ (if (< -1 *rp nvars)
+ (loop2 (not (vector-ref nullable *rp))
+ (cdr stp)
+ (- rp2 1)
+ (cons (map-goto (car stp) *rp) edgp))
+ (loop2 #t stp rp2 edgp)))
+
+ (loop (cdr rulep) edgp))))))))
+ (vector-set! includes i edges)))))
+ (set! includes (transpose includes ngotos)))
+
+
+
+(define (compute-lookaheads)
+ (let ((n (vector-ref lookaheads nstates)))
+ (let loop ((i 0))
+ (if (< i n)
+ (let loop2 ((sp (vector-ref lookback i)))
+ (if (pair? sp)
+ (let ((LA-i (vector-ref LA i))
+ (F-j (vector-ref F (car sp))))
+ (bit-union LA-i F-j token-set-size)
+ (loop2 (cdr sp)))
+ (loop (+ i 1))))))))
+
+
+
+(define (digraph relation)
+ (define infinity (+ ngotos 2))
+ (define INDEX (make-vector (+ ngotos 1) 0))
+ (define VERTICES (make-vector (+ ngotos 1) 0))
+ (define top 0)
+ (define R relation)
+
+ (define (traverse i)
+ (set! top (+ 1 top))
+ (vector-set! VERTICES top i)
+ (let ((height top))
+ (vector-set! INDEX i height)
+ (let ((rp (vector-ref R i)))
+ (if (pair? rp)
+ (let loop ((rp2 rp))
+ (if (pair? rp2)
+ (let ((j (car rp2)))
+ (if (= 0 (vector-ref INDEX j))
+ (traverse j))
+ (if (> (vector-ref INDEX i)
+ (vector-ref INDEX j))
+ (vector-set! INDEX i (vector-ref INDEX j)))
+ (let ((F-i (vector-ref F i))
+ (F-j (vector-ref F j)))
+ (bit-union F-i F-j token-set-size))
+ (loop (cdr rp2))))))
+ (if (= (vector-ref INDEX i) height)
+ (let loop ()
+ (let ((j (vector-ref VERTICES top)))
+ (set! top (- top 1))
+ (vector-set! INDEX j infinity)
+ (if (not (= i j))
+ (begin
+ (bit-union (vector-ref F i)
+ (vector-ref F j)
+ token-set-size)
+ (loop)))))))))
+
+ (let loop ((i 0))
+ (if (< i ngotos)
+ (begin
+ (if (and (= 0 (vector-ref INDEX i))
+ (pair? (vector-ref R i)))
+ (traverse i))
+ (loop (+ i 1))))))
+
+
+;; ---------------------------------------------------------------------- ;;
+;; operator precedence management ;;
+;; ---------------------------------------------------------------------- ;;
+
+; a vector of precedence descriptors where each element
+; is of the form (terminal type precedence)
+(define the-terminals/prec #f) ; terminal symbols with precedence
+; the precedence is an integer >= 0
+(define (get-symbol-precedence sym)
+ (caddr (vector-ref the-terminals/prec sym)))
+; the operator type is either 'none, 'left, 'right, or 'nonassoc
+(define (get-symbol-assoc sym)
+ (cadr (vector-ref the-terminals/prec sym)))
+
+(define rule-precedences '())
+(define (add-rule-precedence! rule sym)
+ (set! rule-precedences
+ (cons (cons rule sym) rule-precedences)))
+
+(define (get-rule-precedence ruleno)
+ (cond
+ ((assq ruleno rule-precedences)
+ => (lambda (p)
+ (get-symbol-precedence (cdr p))))
+ (else
+ ;; process the rule symbols from left to right
+ (let loop ((i (vector-ref rrhs ruleno))
+ (prec 0))
+ (let ((item (vector-ref ritem i)))
+ ;; end of rule
+ (if (< item 0)
+ prec
+ (let ((i1 (+ i 1)))
+ (if (>= item nvars)
+ ;; it's a terminal symbol
+ (loop i1 (get-symbol-precedence (- item nvars)))
+ (loop i1 prec)))))))))
+
+;; ---------------------------------------------------------------------- ;;
+;; Build the various tables ;;
+;; ---------------------------------------------------------------------- ;;
+(define (build-tables)
+
+ (define (resolve-conflict sym rule)
+ (let ((sym-prec (get-symbol-precedence sym))
+ (sym-assoc (get-symbol-assoc sym))
+ (rule-prec (get-rule-precedence rule)))
+ (cond
+ ((> sym-prec rule-prec) 'shift)
+ ((< sym-prec rule-prec) 'reduce)
+ ((eq? sym-assoc 'left) 'reduce)
+ ((eq? sym-assoc 'right) 'shift)
+ (else 'shift))))
+
+ ;; --- Add an action to the action table ------------------------------ ;;
+ (define (add-action St Sym Act)
+ (let* ((x (vector-ref action-table St))
+ (y (assv Sym x)))
+ (if y
+ (if (not (= Act (cdr y)))
+ ;; -- there is a conflict
+ (begin
+ (if (and (<= (cdr y) 0)
+ (<= Act 0))
+ ;; --- reduce/reduce conflict ----------------------- ;;
+ (begin
+ (display "%% Reduce/Reduce conflict " (current-error-port))
+ (display "(reduce " (current-error-port))
+ (display (- Act) (current-error-port))
+ (display ", reduce " (current-error-port))
+ (display (- (cdr y)) (current-error-port))
+ (display ") on " (current-error-port))
+ (print-symbol (+ Sym nvars) (current-error-port))
+ (display " in state " (current-error-port))
+ (display St (current-error-port))
+ (newline (current-error-port))
+ (set-cdr! y (max (cdr y) Act)))
+ ;; --- shift/reduce conflict ------------------------ ;;
+ ;; can we resolve the conflict using precedences?
+ (case (resolve-conflict Sym (- (cdr y)))
+ ;; -- shift
+ ((shift)
+ (set-cdr! y Act))
+ ;; -- reduce
+ ((reduce)
+ #f) ; well, nothing to do...
+ ;; -- signal a conflict!
+ (else
+ (display "%% Shift/Reduce conflict " (current-error-port))
+ (display "(shift " (current-error-port))
+ (display Act (current-error-port))
+ (display ", reduce " (current-error-port))
+ (display (- (cdr y)) (current-error-port))
+ (display ") on " (current-error-port))
+ (print-symbol (+ Sym nvars) (current-error-port))
+ (display " in state " (current-error-port))
+ (display St (current-error-port))
+ (newline (current-error-port))
+ (set-cdr! y Act))))))
+
+ (vector-set! action-table St (cons (cons Sym Act) x)))))
+
+ (set! action-table (make-vector nstates '()))
+
+ (do ((i 0 (+ i 1))) ; i = state
+ ((= i nstates))
+ (let ((red (vector-ref reduction-table i)))
+ (if (and red (>= (red-nreds red) 1))
+ (if (and (= (red-nreds red) 1) (vector-ref consistent i))
+ (add-action i 'default (- (car (red-rules red))))
+ (let ((k (vector-ref lookaheads (+ i 1))))
+ (let loop ((j (vector-ref lookaheads i)))
+ (if (< j k)
+ (let ((rule (- (vector-ref LAruleno j)))
+ (lav (vector-ref LA j)))
+ (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
+ (if (< token nterms)
+ (begin
+ (let ((in-la-set? (modulo x 2)))
+ (if (= in-la-set? 1)
+ (add-action i token rule)))
+ (if (= y (BITS-PER-WORD))
+ (loop2 (+ token 1)
+ (vector-ref lav (+ z 1))
+ 1
+ (+ z 1))
+ (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
+ (loop (+ j 1)))))))))
+
+ (let ((shiftp (vector-ref shift-table i)))
+ (if shiftp
+ (let loop ((k (shift-shifts shiftp)))
+ (if (pair? k)
+ (let* ((state (car k))
+ (symbol (vector-ref acces-symbol state)))
+ (if (>= symbol nvars)
+ (add-action i (- symbol nvars) state))
+ (loop (cdr k))))))))
+
+ (add-action final-state 0 'accept))
+
+(define (compact-action-table terms)
+ (define (most-common-action acts)
+ (let ((accums '()))
+ (let loop ((l acts))
+ (if (pair? l)
+ (let* ((x (cdar l))
+ (y (assv x accums)))
+ (if (and (number? x) (< x 0))
+ (if y
+ (set-cdr! y (+ 1 (cdr y)))
+ (set! accums (cons `(,x . 1) accums))))
+ (loop (cdr l)))))
+
+ (let loop ((l accums) (max 0) (sym #f))
+ (if (null? l)
+ sym
+ (let ((x (car l)))
+ (if (> (cdr x) max)
+ (loop (cdr l) (cdr x) (car x))
+ (loop (cdr l) max sym)))))))
+
+ (define (translate-terms acts)
+ (map (lambda (act)
+ (cons (list-ref terms (car act))
+ (cdr act)))
+ acts))
+
+ (do ((i 0 (+ i 1)))
+ ((= i nstates))
+ (let ((acts (vector-ref action-table i)))
+ (if (vector? (vector-ref reduction-table i))
+ (let ((act (most-common-action acts)))
+ (vector-set! action-table i
+ (cons `(*default* . ,(if act act 'error))
+ (translate-terms
+ (lalr-filter (lambda (x)
+ (not (eq? (cdr x) act)))
+ acts)))))
+ (vector-set! action-table i
+ (cons `(*default* . *error*)
+ (translate-terms acts)))))))
+
+
+
+;; --
+
+(define (rewrite-grammar tokens grammar k)
+
+ (define eoi '*eoi*)
+
+ (define (check-terminal term terms)
+ (cond
+ ((not (valid-terminal? term))
+ (lalr-error "invalid terminal: " term))
+ ((member term terms)
+ (lalr-error "duplicate definition of terminal: " term))))
+
+ (define (prec->type prec)
+ (cdr (assq prec '((left: . left)
+ (right: . right)
+ (nonassoc: . nonassoc)))))
+
+ (cond
+ ;; --- a few error conditions ---------------------------------------- ;;
+ ((not (list? tokens))
+ (lalr-error "Invalid token list: " tokens))
+ ((not (pair? grammar))
+ (lalr-error "Grammar definition must have a non-empty list of productions" '()))
+
+ (else
+ ;; --- check the terminals ---------------------------------------- ;;
+ (let loop1 ((lst tokens)
+ (rev-terms '())
+ (rev-terms/prec '())
+ (prec-level 0))
+ (if (pair? lst)
+ (let ((term (car lst)))
+ (cond
+ ((pair? term)
+ (if (and (memq (car term) '(left: right: nonassoc:))
+ (not (null? (cdr term))))
+ (let ((prec (+ prec-level 1))
+ (optype (prec->type (car term))))
+ (let loop-toks ((l (cdr term))
+ (rev-terms rev-terms)
+ (rev-terms/prec rev-terms/prec))
+ (if (null? l)
+ (loop1 (cdr lst) rev-terms rev-terms/prec prec)
+ (let ((term (car l)))
+ (check-terminal term rev-terms)
+ (loop-toks
+ (cdr l)
+ (cons term rev-terms)
+ (cons (list term optype prec) rev-terms/prec))))))
+
+ (lalr-error "invalid operator precedence specification: " term)))
+
+ (else
+ (check-terminal term rev-terms)
+ (loop1 (cdr lst)
+ (cons term rev-terms)
+ (cons (list term 'none 0) rev-terms/prec)
+ prec-level))))
+
+ ;; --- check the grammar rules ------------------------------ ;;
+ (let loop2 ((lst grammar) (rev-nonterm-defs '()))
+ (if (pair? lst)
+ (let ((def (car lst)))
+ (if (not (pair? def))
+ (lalr-error "Nonterminal definition must be a non-empty list" '())
+ (let ((nonterm (car def)))
+ (cond ((not (valid-nonterminal? nonterm))
+ (lalr-error "Invalid nonterminal:" nonterm))
+ ((or (member nonterm rev-terms)
+ (assoc nonterm rev-nonterm-defs))
+ (lalr-error "Nonterminal previously defined:" nonterm))
+ (else
+ (loop2 (cdr lst)
+ (cons def rev-nonterm-defs)))))))
+ (let* ((terms (cons eoi (reverse rev-terms)))
+ (terms/prec (cons '(eoi none 0) (reverse rev-terms/prec)))
+ (nonterm-defs (reverse rev-nonterm-defs))
+ (nonterms (cons '*start* (map car nonterm-defs))))
+ (if (= (length nonterms) 1)
+ (lalr-error "Grammar must contain at least one nonterminal" '())
+ (let loop-defs ((defs (cons `(*start* (,(cadr nonterms) ,eoi) -> $1)
+ nonterm-defs))
+ (ruleno 0)
+ (comp-defs '()))
+ (if (pair? defs)
+ (let* ((nonterm-def (car defs))
+ (compiled-def (rewrite-nonterm-def
+ nonterm-def
+ ruleno
+ terms nonterms)))
+ (loop-defs (cdr defs)
+ (+ ruleno (length compiled-def))
+ (cons compiled-def comp-defs)))
+
+ (let ((compiled-nonterm-defs (reverse comp-defs)))
+ (k terms
+ terms/prec
+ nonterms
+ (map (lambda (x) (cons (caaar x) (map cdar x)))
+ compiled-nonterm-defs)
+ (apply append compiled-nonterm-defs))))))))))))))
+
+
+(define *arrow* '->)
+
+(define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
+
+ (define No-NT (length nonterms))
+
+ (define (encode x)
+ (let ((PosInNT (pos-in-list x nonterms)))
+ (if PosInNT
+ PosInNT
+ (let ((PosInT (pos-in-list x terms)))
+ (if PosInT
+ (+ No-NT PosInT)
+ (lalr-error "undefined symbol : " x))))))
+
+ (define (process-prec-directive rhs ruleno)
+ (let loop ((l rhs))
+ (if (null? l)
+ '()
+ (let ((first (car l))
+ (rest (cdr l)))
+ (cond
+ ((or (member first terms) (member first nonterms))
+ (cons first (loop rest)))
+ ((and (pair? first)
+ (eq? (car first) 'prec:))
+ (pair? (cdr first))
+ (if (and (pair? (cdr first))
+ (member (cadr first) terms))
+ (if (null? (cddr first))
+ (begin
+ (add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
+ (loop rest))
+ (lalr-error "prec: directive should be at end of rule: " rhs))
+ (lalr-error "Invalid prec: directive: " first)))
+ (else
+ (lalr-error "Invalid terminal or nonterminal: " first)))))))
+
+
+ (if (not (pair? (cdr nonterm-def)))
+ (lalr-error "At least one production needed for nonterminal" (car nonterm-def))
+ (let ((name (symbol->string (car nonterm-def))))
+ (let loop1 ((lst (cdr nonterm-def))
+ (i 1)
+ (rev-productions-and-actions '()))
+ (if (not (pair? lst))
+ (reverse rev-productions-and-actions)
+ (let* ((rhs (process-prec-directive (car lst) (+ ruleno i -1)))
+ (rest (cdr lst))
+ (prod (map encode (cons (car nonterm-def) rhs))))
+ (for-each (lambda (x)
+ (if (not (or (member x terms) (member x nonterms)))
+ (lalr-error "Invalid terminal or nonterminal" x)))
+ rhs)
+ (if (and (pair? rest)
+ (eq? (car rest) *arrow*)
+ (pair? (cdr rest)))
+ (loop1 (cddr rest)
+ (+ i 1)
+ (cons (cons prod (cadr rest))
+ rev-productions-and-actions))
+ (let* ((rhs-length (length rhs))
+ (action
+ (cons 'vector
+ (cons (list 'quote (string->symbol
+ (string-append
+ name
+ "-"
+ (number->string i))))
+ (let loop-j ((j 1))
+ (if (> j rhs-length)
+ '()
+ (cons (string->symbol
+ (string-append
+ "$"
+ (number->string j)))
+ (loop-j (+ j 1)))))))))
+ (loop1 rest
+ (+ i 1)
+ (cons (cons prod action)
+ rev-productions-and-actions))))))))))
+
+(define (valid-nonterminal? x)
+ (symbol? x))
+
+(define (valid-terminal? x)
+ (symbol? x)) ; DB
+
+;; ---------------------------------------------------------------------- ;;
+;; Miscellaneous ;;
+;; ---------------------------------------------------------------------- ;;
+(define (pos-in-list x lst)
+ (let loop ((lst lst) (i 0))
+ (cond ((not (pair? lst)) #f)
+ ((equal? (car lst) x) i)
+ (else (loop (cdr lst) (+ i 1))))))
+
+(define (sunion lst1 lst2) ; union of sorted lists
+ (let loop ((L1 lst1)
+ (L2 lst2))
+ (cond ((null? L1) L2)
+ ((null? L2) L1)
+ (else
+ (let ((x (car L1)) (y (car L2)))
+ (cond
+ ((> x y)
+ (cons y (loop L1 (cdr L2))))
+ ((< x y)
+ (cons x (loop (cdr L1) L2)))
+ (else
+ (loop (cdr L1) L2))
+ ))))))
+
+(define (sinsert elem lst)
+ (let loop ((l1 lst))
+ (if (null? l1)
+ (cons elem l1)
+ (let ((x (car l1)))
+ (cond ((< elem x)
+ (cons elem l1))
+ ((> elem x)
+ (cons x (loop (cdr l1))))
+ (else
+ l1))))))
+
+(define (lalr-filter p lst)
+ (let loop ((l lst))
+ (if (null? l)
+ '()
+ (let ((x (car l)) (y (cdr l)))
+ (if (p x)
+ (cons x (loop y))
+ (loop y))))))
+
+;; ---------------------------------------------------------------------- ;;
+;; Debugging tools ... ;;
+;; ---------------------------------------------------------------------- ;;
+(define the-terminals #f) ; names of terminal symbols
+(define the-nonterminals #f) ; non-terminals
+
+(define (print-item item-no)
+ (let loop ((i item-no))
+ (let ((v (vector-ref ritem i)))
+ (if (>= v 0)
+ (loop (+ i 1))
+ (let* ((rlno (- v))
+ (nt (vector-ref rlhs rlno)))
+ (display (vector-ref the-nonterminals nt)) (display " --> ")
+ (let loop ((i (vector-ref rrhs rlno)))
+ (let ((v (vector-ref ritem i)))
+ (if (= i item-no)
+ (display ". "))
+ (if (>= v 0)
+ (begin
+ (print-symbol v)
+ (display " ")
+ (loop (+ i 1)))
+ (begin
+ (display " (rule ")
+ (display (- v))
+ (display ")")
+ (newline))))))))))
+
+(define (print-symbol n . port)
+ (display (if (>= n nvars)
+ (vector-ref the-terminals (- n nvars))
+ (vector-ref the-nonterminals n))
+ (if (null? port)
+ (current-output-port)
+ (car port))))
+
+(define (print-states)
+"Print the states of a generated parser."
+ (define (print-action act)
+ (cond
+ ((eq? act '*error*)
+ (display " : Error"))
+ ((eq? act 'accept)
+ (display " : Accept input"))
+ ((< act 0)
+ (display " : reduce using rule ")
+ (display (- act)))
+ (else
+ (display " : shift and goto state ")
+ (display act)))
+ (newline)
+ #t)
+
+ (define (print-actions acts)
+ (let loop ((l acts))
+ (if (null? l)
+ #t
+ (let ((sym (caar l))
+ (act (cdar l)))
+ (display " ")
+ (cond
+ ((eq? sym 'default)
+ (display "default action"))
+ (else
+ (if (number? sym)
+ (print-symbol (+ sym nvars))
+ (display sym))))
+ (print-action act)
+ (loop (cdr l))))))
+
+ (if (not action-table)
+ (begin
+ (display "No generated parser available!")
+ (newline)
+ #f)
+ (begin
+ (display "State table") (newline)
+ (display "-----------") (newline) (newline)
+
+ (let loop ((l first-state))
+ (if (null? l)
+ #t
+ (let* ((core (car l))
+ (i (core-number core))
+ (items (core-items core))
+ (actions (vector-ref action-table i)))
+ (display "state ") (display i) (newline)
+ (newline)
+ (for-each (lambda (x) (display " ") (print-item x))
+ items)
+ (newline)
+ (print-actions actions)
+ (newline)
+ (loop (cdr l))))))))
+
+
+
+;; ---------------------------------------------------------------------- ;;
+
+(define build-goto-table
+ (lambda ()
+ `(vector
+ ,@(map
+ (lambda (shifts)
+ (list 'quote
+ (if shifts
+ (let loop ((l (shift-shifts shifts)))
+ (if (null? l)
+ '()
+ (let* ((state (car l))
+ (symbol (vector-ref acces-symbol state)))
+ (if (< symbol nvars)
+ (cons `(,symbol . ,state)
+ (loop (cdr l)))
+ (loop (cdr l))))))
+ '())))
+ (vector->list shift-table)))))
+
+
+(define build-reduction-table
+ (lambda (gram/actions)
+ `(vector
+ '()
+ ,@(map
+ (lambda (p)
+ (let ((act (cdr p)))
+ `(lambda (___stack ___sp ___goto-table ___k)
+ ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
+ `(let* (,@(if act
+ (let loop ((i 1) (l rhs))
+ (if (pair? l)
+ (let ((rest (cdr l)))
+ (cons
+ `(,(string->symbol
+ (string-append
+ "$"
+ (number->string
+ (+ (- n i) 1))))
+ (vector-ref ___stack (- ___sp ,(- (* i 2) 1))))
+ (loop (+ i 1) rest)))
+ '()))
+ '()))
+ ,(if (= nt 0)
+ '$1
+ `(___push ___stack (- ___sp ,(* 2 n))
+ ,nt ___goto-table ,(cdr p) ___k)))))))
+
+ gram/actions))))
+
+
+;; @section (api "API")
+
+(define-macro (lalr-parser tokens . rules)
+ (let* ((gram/actions (gen-tables! tokens rules))
+ (code
+ `(letrec ((___max-stack-size 500)
+
+ (___atable ',action-table)
+ (___gtable ,(build-goto-table))
+ (___grow-stack (lambda (stack)
+ ;; make a new stack twice as big as the original
+ (let ((new-stack (make-vector (* 2 (vector-length stack)) #f)))
+ ;; then copy the elements...
+ (let loop ((i (- (vector-length stack) 1)))
+ (if (< i 0)
+ new-stack
+ (begin
+ (vector-set! new-stack i (vector-ref stack i))
+ (loop (- i 1))))))))
+
+ (___push (lambda (stack sp new-cat goto-table lval k)
+ (let* ((state (vector-ref stack sp))
+ (new-state (cdr (assq new-cat (vector-ref goto-table state))))
+ (new-sp (+ sp 2))
+ (stack (if (< new-sp (vector-length stack))
+ stack
+ (___grow-stack stack))))
+ (vector-set! stack new-sp new-state)
+ (vector-set! stack (- new-sp 1) lval)
+ (k stack new-sp))))
+
+ (___action (lambda (x l)
+ (let ((y (assq x l)))
+ (if y (cdr y) (cdar l)))))
+
+ (___rtable ,(build-reduction-table gram/actions)))
+
+ (lambda (lexerp errorp)
+
+ (let ((stack (make-vector ___max-stack-size 0)))
+ (let loop ((stack stack) (sp 0) (input (lexerp)))
+ (let* ((state (vector-ref stack sp))
+ (i (if (pair? input) (car input) input))
+ (attr (if (pair? input) (cdr input) #f))
+ (act (___action i (vector-ref ___atable state))))
+
+ (if (not (symbol? i))
+ (errorp "PARSE ERROR: invalid token: " input))
+
+ (cond
+
+ ;; Input succesfully parsed
+ ((eq? act 'accept)
+ (vector-ref stack 1))
+
+ ;; Syntax error in input
+ ((eq? act '*error*)
+ (if (eq? i '*eoi*)
+ (errorp "PARSE ERROR : unexpected end of input ")
+ (errorp "PARSE ERROR : unexpected token : " input)))
+
+ ;; Shift current token on top of the stack
+ ((>= act 0)
+ (let ((stack (if (< (+ sp 2) (vector-length stack))
+ stack
+ (___grow-stack stack))))
+ (vector-set! stack (+ sp 1) attr)
+ (vector-set! stack (+ sp 2) act)
+ (loop stack (+ sp 2) (lexerp))))
+
+ ;; Reduce by rule (- act)
+ (else
+ ((vector-ref ___rtable (- act))
+ stack sp ___gtable
+ (lambda (stack sp)
+ (loop stack sp input))))))))))))
+ code))
+
+;; arch-tag: 4FE771DE-F56D-11D8-8B77-000A95B4C7DC
--- /dev/null
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 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 ecmascript parse)
+ #:use-module (language ecmascript parse-lalr)
+ #:use-module (language ecmascript tokenize)
+ #:export (read-ecmascript read-ecmascript/1 parse-ecmascript))
+
+(define (syntax-error message . args)
+ (apply throw 'SyntaxError message args))
+
+(define (read-ecmascript port)
+ (parse-ecmascript (make-tokenizer port) syntax-error))
+
+(define (read-ecmascript/1 port)
+ (parse-ecmascript (make-tokenizer/1 port) syntax-error))
+
+(define *eof-object*
+ (call-with-input-string "" read-char))
+
+(define parse-ecmascript
+ (lalr-parser
+ ;; terminal (i.e. input) token types
+ (lbrace rbrace lparen rparen lbracket rbracket dot semicolon comma <
+ > <= >= == != === !== + - * % ++ -- << >> >>> & bor ^ ! ~ && or ?
+ colon = += -= *= %= <<= >>= >>>= &= bor= ^= / /=
+
+ break else new var case finally return void catch for switch while
+ continue function this with default if throw delete in try do
+ instanceof typeof null true false
+
+ Identifier StringLiteral NumericLiteral RegexpLiteral)
+
+
+ (Program (SourceElements) -> $1
+ (*eoi*) -> *eof-object*)
+
+ ;;
+ ;; Verily, here we define statements. Expressions are defined
+ ;; afterwards.
+ ;;
+
+ (SourceElement (Statement) -> $1
+ (FunctionDeclaration) -> $1)
+
+ (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(var (,$2 (lambda () ,$6)))
+ (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(var (,$2 (lambda ,$4 ,$7))))
+ (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) -> `(lambda () ,$5)
+ (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(lambda () ,$6)
+ (function lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(lambda ,$3 ,$6)
+ (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(lambda ,$4 ,$7))
+ (FormalParameterList (Identifier) -> `(,$1)
+ (FormalParameterList comma Identifier) -> `(,@$1 ,$3))
+ (SourceElements (SourceElement) -> $1
+ (SourceElements SourceElement) -> (if (and (pair? $1) (eq? (car $1) 'begin))
+ `(begin ,@(cdr $1) ,$2)
+ `(begin ,$1 ,$2)))
+ (FunctionBody (SourceElements) -> $1)
+
+ (Statement (Block) -> $1
+ (VariableStatement) -> $1
+ (EmptyStatement) -> $1
+ (ExpressionStatement) -> $1
+ (IfStatement) -> $1
+ (IterationStatement) -> $1
+ (ContinueStatement) -> $1
+ (BreakStatement) -> $1
+ (ReturnStatement) -> $1
+ (WithStatement) -> $1
+ (LabelledStatement) -> $1
+ (SwitchStatement) -> $1
+ (ThrowStatement) -> $1
+ (TryStatement) -> $1)
+
+ (Block (lbrace StatementList rbrace) -> `(block ,$2))
+ (StatementList (Statement) -> $1
+ (StatementList Statement) -> (if (and (pair? $1) (eq? (car $1) 'begin))
+ `(begin ,@(cdr $1) ,$2)
+ `(begin ,$1 ,$2)))
+
+ (VariableStatement (var VariableDeclarationList) -> `(var ,@$2))
+ (VariableDeclarationList (VariableDeclaration) -> `(,$1)
+ (VariableDeclarationList comma VariableDeclaration) -> `(,@$1 ,$2))
+ (VariableDeclarationListNoIn (VariableDeclarationNoIn) -> `(,$1)
+ (VariableDeclarationListNoIn comma VariableDeclarationNoIn) -> `(,@$1 ,$2))
+ (VariableDeclaration (Identifier) -> `(,$1)
+ (Identifier Initialiser) -> `(,$1 ,$2))
+ (VariableDeclarationNoIn (Identifier) -> `(,$1)
+ (Identifier Initialiser) -> `(,$1 ,$2))
+ (Initialiser (= AssignmentExpression) -> $2)
+ (InitialiserNoIn (= AssignmentExpressionNoIn) -> $2)
+
+ (EmptyStatement (semicolon) -> '(begin))
+
+ (ExpressionStatement (Expression semicolon) -> $1)
+
+ (IfStatement (if lparen Expression rparen Statement else Statement) -> `(if ,$3 ,$5 ,$7)
+ (if lparen Expression rparen Statement) -> `(if ,$3 ,$5))
+
+ (IterationStatement (do Statement while lparen Expression rparen semicolon) -> `(do ,$2 ,$5)
+
+ (while lparen Expression rparen Statement) -> `(while ,$3 ,$5)
+
+ (for lparen semicolon semicolon rparen Statement) -> `(for #f #f #f ,$6)
+ (for lparen semicolon semicolon Expression rparen Statement) -> `(for #f #f ,$5 ,$7)
+ (for lparen semicolon Expression semicolon rparen Statement) -> `(for #f ,$4 #f ,$7)
+ (for lparen semicolon Expression semicolon Expression rparen Statement) -> `(for #f ,$4 ,$6 ,$8)
+
+ (for lparen ExpressionNoIn semicolon semicolon rparen Statement) -> `(for ,$3 #f #f ,$7)
+ (for lparen ExpressionNoIn semicolon semicolon Expression rparen Statement) -> `(for ,$3 #f ,$6 ,$8)
+ (for lparen ExpressionNoIn semicolon Expression semicolon rparen Statement) -> `(for ,$3 ,$5 #f ,$8)
+ (for lparen ExpressionNoIn semicolon Expression semicolon Expression rparen Statement) -> `(for ,$3 ,$5 ,$7 ,$9)
+
+ (for lparen var VariableDeclarationListNoIn semicolon semicolon rparen Statement) -> `(for (var ,@$4) #f #f ,$8)
+ (for lparen var VariableDeclarationListNoIn semicolon semicolon Expression rparen Statement) -> `(for (var ,@$4) #f ,$7 ,$9)
+ (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon rparen Statement) -> `(for (var ,@$4) ,$6 #f ,$9)
+ (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon Expression rparen Statement) -> `(for (var ,@$4) ,$6 ,$8 ,$10)
+
+ (for lparen LeftHandSideExpression in Expression rparen Statement) -> `(for-in ,$3 ,$5 ,$7)
+ (for lparen var VariableDeclarationNoIn in Expression rparen Statement) -> `(begin (var ,$4) (for-in (ref ,@$4) ,$6 ,$8)))
+
+ (ContinueStatement (continue Identifier semicolon) -> `(continue ,$2)
+ (continue semicolon) -> `(continue))
+
+ (BreakStatement (break Identifier semicolon) -> `(break ,$2)
+ (break semicolon) -> `(break))
+
+ (ReturnStatement (return Expression semicolon) -> `(return ,$2)
+ (return semicolon) -> `(return))
+
+ (WithStatement (with lparen Expression rparen Statement) -> `(with ,$3 ,$5))
+
+ (SwitchStatement (switch lparen Expression rparen CaseBlock) -> `(switch ,$3 ,@$5))
+ (CaseBlock (lbrace rbrace) -> '()
+ (lbrace CaseClauses rbrace) -> $2
+ (lbrace CaseClauses DefaultClause rbrace) -> `(,@$2 ,@$3)
+ (lbrace DefaultClause rbrace) -> `(,$2)
+ (lbrace DefaultClause CaseClauses rbrace) -> `(,@$2 ,@$3))
+ (CaseClauses (CaseClause) -> `(,$1)
+ (CaseClauses CaseClause) -> `(,@$1 ,$2))
+ (CaseClause (case Expression colon) -> `(case ,$2)
+ (case Expression colon StatementList) -> `(case ,$2 ,$4))
+ (DefaultClause (default colon) -> `(default)
+ (default colon StatementList) -> `(default ,$3))
+
+ (LabelledStatement (Identifier colon Statement) -> `(label ,$1 ,$3))
+
+ (ThrowStatement (throw Expression semicolon) -> `(throw ,$2))
+
+ (TryStatement (try Block Catch) -> `(try ,$2 ,$3 #f)
+ (try Block Finally) -> `(try ,$2 #f ,$3)
+ (try Block Catch Finally) -> `(try ,$2 ,$3 ,$4))
+ (Catch (catch lparen Identifier rparen Block) -> `(catch ,$3 ,$5))
+ (Finally (finally Block) -> `(finally ,$2))
+
+ ;;
+ ;; As promised, expressions. We build up to Expression bottom-up, so
+ ;; as to get operator precedence right.
+ ;;
+
+ (PrimaryExpression (this) -> 'this
+ (null) -> 'null
+ (true) -> 'true
+ (false) -> 'false
+ (Identifier) -> `(ref ,$1)
+ (StringLiteral) -> `(string ,$1)
+ (RegexpLiteral) -> `(regexp ,$1)
+ (NumericLiteral) -> `(number ,$1)
+ (ArrayLiteral) -> $1
+ (ObjectLiteral) -> $1
+ (lparen Expression rparen) -> $2)
+
+ (ArrayLiteral (lbracket rbracket) -> '(array)
+ (lbracket Elision rbracket) -> '(array ,@$2)
+ (lbracket ElementList rbracket) -> `(array ,@$2)
+ (lbracket ElementList comma rbracket) -> `(array ,@$2)
+ (lbracket ElementList comma Elision rbracket) -> `(array ,@$2))
+ (ElementList (AssignmentExpression) -> `(,$1)
+ (Elision AssignmentExpression) -> `(,@$1 ,$2)
+ (ElementList comma AssignmentExpression) -> `(,@$1 ,$3)
+ (ElementList comma Elision AssignmentExpression) -> `(,@$1 ,@$3 ,$4))
+ (Elision (comma) -> '((number 0))
+ (Elision comma) -> `(,@$1 (number 0)))
+
+ (ObjectLiteral (lbrace rbrace) -> `(object)
+ (lbrace PropertyNameAndValueList rbrace) -> `(object ,@$2))
+ (PropertyNameAndValueList (PropertyName colon AssignmentExpression) -> `((,$1 ,$3))
+ (PropertyNameAndValueList comma PropertyName colon AssignmentExpression) -> `(,@$1 (,$3 ,$5)))
+ (PropertyName (Identifier) -> $1
+ (StringLiteral) -> (string->symbol $1)
+ (NumericLiteral) -> $1)
+
+ (MemberExpression (PrimaryExpression) -> $1
+ (FunctionExpression) -> $1
+ (MemberExpression lbracket Expression rbracket) -> `(aref ,$1 ,$3)
+ (MemberExpression dot Identifier) -> `(pref ,$1 ,$3)
+ (new MemberExpression Arguments) -> `(new ,$2 ,$3))
+
+ (NewExpression (MemberExpression) -> $1
+ (new NewExpression) -> `(new ,$2 ()))
+
+ (CallExpression (MemberExpression Arguments) -> `(call ,$1 ,$2)
+ (CallExpression Arguments) -> `(call ,$1 ,$2)
+ (CallExpression lbracket Expression rbracket) -> `(aref ,$1 ,$3)
+ (CallExpression dot Identifier) -> `(pref ,$1 ,$3))
+ (Arguments (lparen rparen) -> '()
+ (lparen ArgumentList rparen) -> $2)
+ (ArgumentList (AssignmentExpression) -> `(,$1)
+ (ArgumentList comma AssignmentExpression) -> `(,@$1 ,$3))
+
+ (LeftHandSideExpression (NewExpression) -> $1
+ (CallExpression) -> $1)
+
+ (PostfixExpression (LeftHandSideExpression) -> $1
+ (LeftHandSideExpression ++) -> `(postinc ,$1)
+ (LeftHandSideExpression --) -> `(postdec ,$1))
+
+ (UnaryExpression (PostfixExpression) -> $1
+ (delete UnaryExpression) -> `(delete ,$2)
+ (void UnaryExpression) -> `(void ,$2)
+ (typeof UnaryExpression) -> `(typeof ,$2)
+ (++ UnaryExpression) -> `(preinc ,$2)
+ (-- UnaryExpression) -> `(predec ,$2)
+ (+ UnaryExpression) -> `(+ ,$2)
+ (- UnaryExpression) -> `(- ,$2)
+ (~ UnaryExpression) -> `(~ ,$2)
+ (! UnaryExpression) -> `(! ,$2))
+
+ (MultiplicativeExpression (UnaryExpression) -> $1
+ (MultiplicativeExpression * UnaryExpression) -> `(* ,$1 ,$3)
+ (MultiplicativeExpression / UnaryExpression) -> `(/ ,$1 ,$3)
+ (MultiplicativeExpression % UnaryExpression) -> `(% ,$1 ,$3))
+
+ (AdditiveExpression (MultiplicativeExpression) -> $1
+ (AdditiveExpression + MultiplicativeExpression) -> `(+ ,$1 ,$3)
+ (AdditiveExpression - MultiplicativeExpression) -> `(- ,$1 ,$3))
+
+ (ShiftExpression (AdditiveExpression) -> $1
+ (ShiftExpression << MultiplicativeExpression) -> `(<< ,$1 ,$3)
+ (ShiftExpression >> MultiplicativeExpression) -> `(>> ,$1 ,$3)
+ (ShiftExpression >>> MultiplicativeExpression) -> `(>>> ,$1 ,$3))
+
+ (RelationalExpression (ShiftExpression) -> $1
+ (RelationalExpression < ShiftExpression) -> `(< ,$1 ,$3)
+ (RelationalExpression > ShiftExpression) -> `(> ,$1 ,$3)
+ (RelationalExpression <= ShiftExpression) -> `(<= ,$1 ,$3)
+ (RelationalExpression >= ShiftExpression) -> `(>= ,$1 ,$3)
+ (RelationalExpression instanceof ShiftExpression) -> `(instanceof ,$1 ,$3)
+ (RelationalExpression in ShiftExpression) -> `(in ,$1 ,$3))
+
+ (RelationalExpressionNoIn (ShiftExpression) -> $1
+ (RelationalExpressionNoIn < ShiftExpression) -> `(< ,$1 ,$3)
+ (RelationalExpressionNoIn > ShiftExpression) -> `(> ,$1 ,$3)
+ (RelationalExpressionNoIn <= ShiftExpression) -> `(<= ,$1 ,$3)
+ (RelationalExpressionNoIn >= ShiftExpression) -> `(>= ,$1 ,$3)
+ (RelationalExpressionNoIn instanceof ShiftExpression) -> `(instanceof ,$1 ,$3))
+
+ (EqualityExpression (RelationalExpression) -> $1
+ (EqualityExpression == RelationalExpression) -> `(== ,$1 ,$3)
+ (EqualityExpression != RelationalExpression) -> `(!= ,$1 ,$3)
+ (EqualityExpression === RelationalExpression) -> `(=== ,$1 ,$3)
+ (EqualityExpression !== RelationalExpression) -> `(!== ,$1 ,$3))
+
+ (EqualityExpressionNoIn (RelationalExpressionNoIn) -> $1
+ (EqualityExpressionNoIn == RelationalExpressionNoIn) -> `(== ,$1 ,$3)
+ (EqualityExpressionNoIn != RelationalExpressionNoIn) -> `(!= ,$1 ,$3)
+ (EqualityExpressionNoIn === RelationalExpressionNoIn) -> `(=== ,$1 ,$3)
+ (EqualityExpressionNoIn !== RelationalExpressionNoIn) -> `(!== ,$1 ,$3))
+
+ (BitwiseANDExpression (EqualityExpression) -> $1
+ (BitwiseANDExpression & EqualityExpression) -> `(& ,$1 ,$3))
+ (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) -> $1
+ (BitwiseANDExpressionNoIn & EqualityExpressionNoIn) -> `(& ,$1 ,$3))
+
+ (BitwiseXORExpression (BitwiseANDExpression) -> $1
+ (BitwiseXORExpression ^ BitwiseANDExpression) -> `(^ ,$1 ,$3))
+ (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) -> $1
+ (BitwiseXORExpressionNoIn ^ BitwiseANDExpressionNoIn) -> `(^ ,$1 ,$3))
+
+ (BitwiseORExpression (BitwiseXORExpression) -> $1
+ (BitwiseORExpression bor BitwiseXORExpression) -> `(bor ,$1 ,$3))
+ (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) -> $1
+ (BitwiseORExpressionNoIn bor BitwiseXORExpressionNoIn) -> `(bor ,$1 ,$3))
+
+ (LogicalANDExpression (BitwiseORExpression) -> $1
+ (LogicalANDExpression && BitwiseORExpression) -> `(and ,$1 ,$3))
+ (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) -> $1
+ (LogicalANDExpressionNoIn && BitwiseORExpressionNoIn) -> `(and ,$1 ,$3))
+
+ (LogicalORExpression (LogicalANDExpression) -> $1
+ (LogicalORExpression or LogicalANDExpression) -> `(or ,$1 ,$3))
+ (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) -> $1
+ (LogicalORExpressionNoIn or LogicalANDExpressionNoIn) -> `(or ,$1 ,$3))
+
+ (ConditionalExpression (LogicalORExpression) -> $1
+ (LogicalORExpression ? AssignmentExpression colon AssignmentExpression) -> `(if ,$1 ,$3 ,$5))
+ (ConditionalExpressionNoIn (LogicalORExpressionNoIn) -> $1
+ (LogicalORExpressionNoIn ? AssignmentExpressionNoIn colon AssignmentExpressionNoIn) -> `(if ,$1 ,$3 ,$5))
+
+ (AssignmentExpression (ConditionalExpression) -> $1
+ (LeftHandSideExpression AssignmentOperator AssignmentExpression) -> `(,$2 ,$1 ,$3))
+ (AssignmentExpressionNoIn (ConditionalExpressionNoIn) -> $1
+ (LeftHandSideExpression AssignmentOperator AssignmentExpressionNoIn) -> `(,$2 ,$1 ,$3))
+ (AssignmentOperator (=) -> '=
+ (*=) -> '*=
+ (/=) -> '/=
+ (%=) -> '%=
+ (+=) -> '+=
+ (-=) -> '-=
+ (<<=) -> '<<=
+ (>>=) -> '>>=
+ (>>>=) -> '>>>=
+ (&=) -> '&=
+ (^=) -> '^=
+ (bor=) -> 'bor=)
+
+ (Expression (AssignmentExpression) -> $1
+ (Expression comma AssignmentExpression) -> `(begin ,$1 ,$3))
+ (ExpressionNoIn (AssignmentExpressionNoIn) -> $1
+ (ExpressionNoIn comma AssignmentExpressionNoIn) -> `(begin ,$1 ,$3))))
--- /dev/null
+;;; ECMAScript specification for Guile
+
+;; Copyright (C) 2009 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 ecmascript spec)
+ #:use-module (system base language)
+ #:use-module (language ecmascript parse)
+ #:use-module (language ecmascript compile-ghil)
+ #:export (ecmascript))
+
+;;;
+;;; Language definition
+;;;
+
+(define-language ecmascript
+ #:title "Guile ECMAScript"
+ #:version "3.0"
+ #:reader (lambda () (read-ecmascript/1 (current-input-port)))
+ #:read-file read-ecmascript
+ #:compilers `((ghil . ,compile-ghil))
+ ;; a pretty-printer would be interesting.
+ #:printer write
+ )
--- /dev/null
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 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 ecmascript tokenize)
+ #:use-module (ice-9 rdelim)
+ #:use-module ((srfi srfi-1) #:select (unfold-right))
+ #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
+
+(define (syntax-error message . args)
+ (apply throw 'SyntaxError message args))
+
+;; taken from SSAX, sorta
+(define (read-until delims port)
+ (if (eof-object? (peek-char port))
+ (syntax-error "EOF while reading a token")
+ (let ((token (read-delimited delims port 'peek)))
+ (if (eof-object? (peek-char port))
+ (syntax-error "EOF while reading a token")
+ token))))
+
+(define (char-hex? c)
+ (and (not (eof-object? c))
+ (or (char-numeric? c)
+ (memv c '(#\a #\b #\c #\d #\e #\f))
+ (memv c '(#\A #\B #\C #\D #\E #\F)))))
+
+(define (digit->number c)
+ (- (char->integer c) (char->integer #\0)))
+
+(define (hex->number c)
+ (if (char-numeric? c)
+ (digit->number c)
+ (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
+
+(define (read-slash port div?)
+ (let* ((c0 (read-char port))
+ (c1 (peek-char port)))
+ (cond
+ ((eof-object? c1)
+ ;; hmm. error if we're not looking for a div? ?
+ '(/ . #f))
+ ((char=? c1 #\/)
+ (read-line port)
+ (next-token port div?))
+ ((char=? c1 #\*)
+ (read-char port)
+ (let lp ((c (read-char port)))
+ (cond
+ ((eof-object? c) (syntax-error "EOF while in multi-line comment"))
+ ((char=? c #\*)
+ (if (eqv? (peek-char port) #\/)
+ (begin
+ (read-char port)
+ (next-token port div?))
+ (lp (read-char port))))
+ (else
+ (lp (read-char port))))))
+ (div?
+ (case c1
+ ((#\=) (read-char port) `(/= . #f))
+ (else `(/ . #f))))
+ (else
+ (read-regexp port)))))
+
+(define (read-regexp port)
+ ;; first slash already read
+ (let ((terms (string #\/ #\\ #\nl #\cr)))
+ (let lp ((str (read-until terms port)) (head ""))
+ (let ((terminator (peek-char port)))
+ (cond
+ ((char=? terminator #\/)
+ (read-char port)
+ ;; flags
+ (let lp ((c (peek-char port)) (flags '()))
+ (if (or (eof-object? c)
+ (not (or (char-alphabetic? c)
+ (char-numeric? c)
+ (char=? c #\$)
+ (char=? c #\_))))
+ `(RegexpLiteral . (,(string-append head str) . ,(reverse flags)))
+ (begin (read-char port)
+ (lp (peek-char port) (cons c flags))))))
+ ((char=? terminator #\\)
+ (read-char port)
+ (let ((echar (read-char port)))
+ (lp (read-until terms port)
+ (string-append head str (string #\\ echar)))))
+ (else
+ (syntax-error "regexp literals may not contain newlines" str)))))))
+
+(define (read-string port)
+ (let ((c (read-char port)))
+ (let ((terms (string c #\\ #\nl #\cr)))
+ (define (read-escape port)
+ (let ((c (read-char port)))
+ (case c
+ ((#\' #\" #\\) c)
+ ((#\b) #\bs)
+ ((#\f) #\np)
+ ((#\n) #\nl)
+ ((#\r) #\cr)
+ ((#\t) #\tab)
+ ((#\v) #\vt)
+ ((#\0)
+ (let ((next (peek-char port)))
+ (cond ((eof-object? next) #\nul)
+ ((char-numeric? next)
+ (syntax-error "octal escape sequences are not supported"))
+ (else #\nul))))
+ ((#\x)
+ (let* ((a (read-char port))
+ (b (read-char port)))
+ (cond
+ ((and (char-hex? a) (char-hex? b))
+ (integer->char (+ (* 16 (hex->number a)) (hex->number b))))
+ (else
+ (syntax-error "bad hex character escape" a b)))))
+ ((#\u)
+ (syntax-error "unicode not supported"))
+ (else
+ c))))
+ (let lp ((str (read-until terms port)))
+ (let ((terminator (peek-char port)))
+ (cond
+ ((char=? terminator c)
+ (read-char port)
+ str)
+ ((char=? terminator #\\)
+ (read-char port)
+ (let ((echar (read-escape port)))
+ (lp (string-append str (string echar)
+ (read-until terms port)))))
+ (else
+ (syntax-error "string literals may not contain newlines" str))))))))
+
+(define *keywords*
+ '(("break" . break)
+ ("else" . else)
+ ("new" . new)
+ ("var" . var)
+ ("case" . case)
+ ("finally" . finally)
+ ("return" . return)
+ ("void" . void)
+ ("catch" . catch)
+ ("for" . for)
+ ("switch" . switch)
+ ("while" . while)
+ ("continue" . continue)
+ ("function" . function)
+ ("this" . this)
+ ("with" . with)
+ ("default" . default)
+ ("if" . if)
+ ("throw" . throw)
+ ("delete" . delete)
+ ("in" . in)
+ ("try" . try)
+ ("do" . do)
+ ("instanceof" . instanceof)
+ ("typeof" . typeof)
+
+ ;; these aren't exactly keywords, but hey
+ ("null" . null)
+ ("true" . true)
+ ("false" . false)))
+
+(define *future-reserved-words*
+ '(("abstract" . abstract)
+ ("enum" . enum)
+ ("int" . int)
+ ("short" . short)
+ ("boolean" . boolean)
+ ("export" . export)
+ ("interface" . interface)
+ ("static" . static)
+ ("byte" . byte)
+ ("extends" . extends)
+ ("long" . long)
+ ("super" . super)
+ ("char" . char)
+ ("final" . final)
+ ("native" . native)
+ ("synchronized" . synchronized)
+ ("class" . class)
+ ("float" . float)
+ ("package" . package)
+ ("throws" . throws)
+ ("const" . const)
+ ("goto" . goto)
+ ("private" . private)
+ ("transient" . transient)
+ ("debugger" . debugger)
+ ("implements" . implements)
+ ("protected" . protected)
+ ("volatile" . volatile)
+ ("double" . double)
+ ("import" . import)
+ ("public" . public)))
+
+(define (read-identifier port)
+ (let lp ((c (peek-char port)) (chars '()))
+ (if (or (eof-object? c)
+ (not (or (char-alphabetic? c)
+ (char-numeric? c)
+ (char=? c #\$)
+ (char=? c #\_))))
+ (let ((word (list->string (reverse chars))))
+ (cond ((assoc-ref *keywords* word)
+ => (lambda (x) `(,x . #f)))
+ ((assoc-ref *future-reserved-words* word)
+ (syntax-error "word is reserved for the future, dude." word))
+ (else `(Identifier . ,(string->symbol word)))))
+ (begin (read-char port)
+ (lp (peek-char port) (cons c chars))))))
+
+(define (read-numeric port)
+ (let* ((c0 (if (char=? (peek-char port) #\.)
+ #\0
+ (read-char port)))
+ (c1 (peek-char port)))
+ (cond
+ ((eof-object? c1) (digit->number c0))
+ ((and (char=? c0 #\0) (char=? c1 #\x))
+ (read-char port)
+ (let ((c (peek-char port)))
+ (if (not (char-hex? c))
+ (syntax-error "bad digit reading hexadecimal number" c))
+ (let lp ((c c) (acc 0))
+ (cond ((char-hex? c)
+ (read-char port)
+ (lp (peek-char port)
+ (+ (* 16 acc) (hex->number c))))
+ (else
+ acc)))))
+ ((and (char=? c0 #\0) (char-numeric? c1))
+ (let lp ((c c1) (acc 0))
+ (cond ((eof-object? c) acc)
+ ((char-numeric? c)
+ (if (or (char=? c #\8) (char=? c #\9))
+ (syntax-error "invalid digit in octal sequence" c))
+ (read-char port)
+ (lp (peek-char port)
+ (+ (* 8 acc) (digit->number c))))
+ (else
+ acc))))
+ (else
+ (let lp ((c1 c1) (acc (digit->number c0)))
+ (cond
+ ((eof-object? c1) acc)
+ ((char-numeric? c1)
+ (read-char port)
+ (lp (peek-char port)
+ (+ (* 10 acc) (digit->number c1))))
+ ((or (char=? c1 #\e) (char=? c1 #\E))
+ (read-char port)
+ (let ((add (let ((c (peek-char port)))
+ (cond ((eof-object? c) (syntax-error "error reading exponent: EOF"))
+ ((char=? c #\+) (read-char port) +)
+ ((char=? c #\-) (read-char port) -)
+ ((char-numeric? c) +)
+ (else (syntax-error "error reading exponent: non-digit"
+ c))))))
+ (let lp ((c (peek-char port)) (e 0))
+ (cond ((and (not (eof-object? c)) (char-numeric? c))
+ (read-char port)
+ (lp (peek-char port) (add (* 10 e) (digit->number c))))
+ (else
+ (* (if (negative? e) (* acc 1.0) acc) (expt 10 e)))))))
+ ((char=? c1 #\.)
+ (read-char port)
+ (let lp2 ((c (peek-char port)) (dec 0.0) (n -1))
+ (cond ((and (not (eof-object? c)) (char-numeric? c))
+ (read-char port)
+ (lp2 (peek-char port)
+ (+ dec (* (digit->number c) (expt 10 n)))
+ (1- n)))
+ (else
+ ;; loop back to catch an exponential part
+ (lp c (+ acc dec))))))
+ (else
+ acc)))))))
+
+(define *punctuation*
+ '(("{" . lbrace)
+ ("}" . rbrace)
+ ("(" . lparen)
+ (")" . rparen)
+ ("[" . lbracket)
+ ("]" . rbracket)
+ ("." . dot)
+ (";" . semicolon)
+ ("," . comma)
+ ("<" . <)
+ (">" . >)
+ ("<=" . <=)
+ (">=" . >=)
+ ("==" . ==)
+ ("!=" . !=)
+ ("===" . ===)
+ ("!==" . !==)
+ ("+" . +)
+ ("-" . -)
+ ("*" . *)
+ ("%" . %)
+ ("++" . ++)
+ ("--" . --)
+ ("<<" . <<)
+ (">>" . >>)
+ (">>>" . >>>)
+ ("&" . &)
+ ("|" . bor)
+ ("^" . ^)
+ ("!" . !)
+ ("~" . ~)
+ ("&&" . &&)
+ ("||" . or)
+ ("?" . ?)
+ (":" . colon)
+ ("=" . =)
+ ("+=" . +=)
+ ("-=" . -=)
+ ("*=" . *=)
+ ("%=" . %=)
+ ("<<=" . <<=)
+ (">>=" . >>=)
+ (">>>=" . >>>=)
+ ("&=" . &=)
+ ("|=" . bor=)
+ ("^=" . ^=)))
+
+(define *div-punctuation*
+ '(("/" . /)
+ ("/=" . /=)))
+
+;; node ::= (char (symbol | #f) node*)
+(define read-punctuation
+ (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*))
+ (cond ((null? puncs)
+ nodes)
+ ((assv-ref nodes (string-ref (caar puncs) 0))
+ => (lambda (node-tail)
+ (if (= (string-length (caar puncs)) 1)
+ (set-car! node-tail (cdar puncs))
+ (set-cdr! node-tail
+ (lp (cdr node-tail)
+ `((,(substring (caar puncs) 1)
+ . ,(cdar puncs))))))
+ (lp nodes (cdr puncs))))
+ (else
+ (lp (cons `(,(string-ref (caar puncs) 0) #f) nodes)
+ puncs))))))
+ (lambda (port)
+ (let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))
+ (cond
+ ((assv-ref tree c)
+ => (lambda (node-tail)
+ (read-char port)
+ (lp (peek-char port) (cdr node-tail) (car node-tail))))
+ (candidate
+ `(,candidate . #f))
+ (else
+ (syntax-error "bad syntax: character not allowed" c)))))))
+
+(define (next-token port div?)
+ (let ((c (peek-char port))
+ (props `((filename . ,(port-filename port))
+ (line . ,(port-line port))
+ (column . ,(port-column port)))))
+ (let ((tok
+ (case c
+ ((#\ht #\vt #\np #\space)
+ ; whitespace
+ (read-char port)
+ (next-token port div?))
+ ((#\newline #\cr)
+ ; line break
+ (read-char port)
+ (next-token port div?))
+ ((#\/)
+ ;; division, single comment, double comment, or regexp
+ (read-slash port div?))
+ ((#\" #\')
+ ; string literal
+ `(StringLiteral . ,(read-string port)))
+ (else
+ (cond
+ ((eof-object? c)
+ '*eoi*)
+ ((or (char-alphabetic? c)
+ (char=? c #\$)
+ (char=? c #\_))
+ ;; reserved word or identifier
+ (read-identifier port))
+ ((char-numeric? c)
+ ;; numeric -- also accept . FIXME, requires lookahead
+ `(NumericLiteral . ,(read-numeric port)))
+ (else
+ ;; punctuation
+ (read-punctuation port)))))))
+ (if (pair? tok)
+ (set-source-properties! tok props))
+ tok)))
+
+(define (make-tokenizer port)
+ (let ((div? #f))
+ (lambda ()
+ (let ((tok (next-token port div?)))
+ (set! div? (and (pair? tok) (eq? (car tok) 'identifier)))
+ tok))))
+
+(define (make-tokenizer/1 port)
+ (let ((div? #f)
+ (eoi? #f)
+ (stack '()))
+ (lambda ()
+ (if eoi?
+ '*eoi*
+ (let ((tok (next-token port div?)))
+ (case (if (pair? tok) (car tok) tok)
+ ((lparen)
+ (set! stack (cons 'lparen stack)))
+ ((rparen)
+ (if (and (pair? stack) (eq? (car stack) 'lparen))
+ (set! stack (cdr stack))
+ (syntax-error "unexpected right parenthesis")))
+ ((lbracket)
+ (set! stack (cons 'lbracket stack)))
+ ((rbracket)
+ (if (and (pair? stack) (eq? (car stack) 'lbracket))
+ (set! stack (cdr stack))
+ (syntax-error "unexpected right bracket" stack)))
+ ((lbrace)
+ (set! stack (cons 'lbrace stack)))
+ ((rbrace)
+ (if (and (pair? stack) (eq? (car stack) 'lbrace))
+ (set! stack (cdr stack))
+ (syntax-error "unexpected right brace" stack)))
+ ((semicolon)
+ (set! eoi? (null? stack))))
+ (set! div? (and (pair? tok)
+ (or (eq? (car tok) 'Identifier)
+ (eq? (car tok) 'NumericLiteral)
+ (eq? (car tok) 'StringLiteral))))
+ tok)))))
+
+(define (tokenize port)
+ (let ((next (make-tokenizer port)))
+ (let lp ((out '()))
+ (let ((tok (next)))
+ (if (eq? tok '*eoi*)
+ (reverse! out)
+ (lp (cons tok out)))))))
+
+(define (tokenize/1 port)
+ (let ((next (make-tokenizer/1 port)))
+ (let lp ((out '()))
+ (let ((tok (next)))
+ (if (eq? tok '*eoi*)
+ (reverse! out)
+ (lp (cons tok out)))))))
+
--- /dev/null
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (lang elisp spec)
+ #:use-module (system lang language)
+ #:export (elisp))
+
+\f
+;;;
+;;; Translator
+;;;
+
+(define (translate x)
+ (if (pair? x)
+ (translate-pair x)
+ x))
+
+(define (translate-pair x)
+ (let ((name (car x)) (args (cdr x)))
+ (case name
+ ((quote) `(@quote ,@args))
+ ((defvar) `(@define ,@(map translate args)))
+ ((setq) `(@set! ,@(map translate args)))
+ ((if) `(@if ,(translate (car args))
+ (@begin ,@(map translate (cdr args)))))
+ ((and) `(@and ,@(map translate args)))
+ ((or) `(@or ,@(map translate args)))
+ ((progn) `(@begin ,@(map translate args)))
+ ((defun) `(@define ,(car args)
+ (@lambda ,(cadr args) ,@(map translate (cddr args)))))
+ ((lambda) `(@lambda ,(car args) ,@(map translate (cdr args))))
+ (else x))))
+
+\f
+;;;
+;;; Language definition
+;;;
+
+(define-language elisp
+ #:title "Emacs Lisp"
+ #:version "0.0"
+ #:reader read
+ #:expander id
+ #:translator translate
+ )
--- /dev/null
+;;; 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)
+ #:use-module (system base syntax)
+ #:use-module (system base pmatch)
+ #:use-module (ice-9 regex)
+ #:export
+ (ghil-env ghil-loc
+
+ <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-splicing-env ghil-unquote-splicing-loc ghil-unquote-splicing-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-reified-env> make-ghil-reified-env ghil-reified-env?
+ ghil-reified-env-env ghil-reified-env-loc
+
+ ghil-env-add!
+ ghil-env-reify ghil-env-dereify
+ 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-ghil unparse-ghil))
+
+\f
+;;;
+;;; Parse tree
+;;;
+
+(define (print-ghil x port)
+ (format port "#<ghil ~s>" (unparse-ghil x)))
+
+(define-type (<ghil> #:printer print-ghil
+ #:common-slots (env loc))
+ ;; Objects
+ (<ghil-void>)
+ (<ghil-quote> obj)
+ (<ghil-quasiquote> exp)
+ (<ghil-unquote> exp)
+ (<ghil-unquote-splicing> exp)
+ ;; Variables
+ (<ghil-ref> var)
+ (<ghil-set> var val)
+ (<ghil-define> var val)
+ ;; Controls
+ (<ghil-if> test then else)
+ (<ghil-and> exps)
+ (<ghil-or> exps)
+ (<ghil-begin> exps)
+ (<ghil-bind> vars vals body)
+ (<ghil-mv-bind> producer vars rest body)
+ (<ghil-lambda> vars rest meta body)
+ (<ghil-call> proc args)
+ (<ghil-mv-call> producer consumer)
+ (<ghil-inline> inline args)
+ (<ghil-values> values)
+ (<ghil-values*> values)
+ (<ghil-reified-env>))
+
+
+\f
+;;;
+;;; Variables
+;;;
+
+(define-record <ghil-var> env name kind (index #f))
+
+\f
+;;;
+;;; Modules
+;;;
+
+\f
+;;;
+;;; 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))
+
+
+\f
+;;;
+;;; 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))
+
+(define (ghil-env-reify env)
+ (let loop ((e env) (out '()))
+ (record-case e
+ ((<ghil-toplevel-env> table)
+ (map (lambda (v)
+ (cons (ghil-var-name v)
+ (or (ghil-var-index v)
+ (error "reify called before indices finalized"))))
+ out))
+ ((<ghil-env> parent table variables)
+ (loop parent
+ (append out
+ (filter (lambda (v) (eq? (ghil-var-kind v) 'external))
+ variables)))))))
+
+(define (ghil-env-dereify name-index-alist)
+ (let* ((e (make-ghil-env (make-ghil-toplevel-env)))
+ (vars (map (lambda (pair)
+ (make-ghil-var e (car pair) 'external (cdr pair)))
+ name-index-alist)))
+ (set! (ghil-env-table e)
+ (map (lambda (v) (cons (ghil-var-name v) v)) vars))
+ (set! (ghil-env-variables e) vars)
+ e))
+
+\f
+;;;
+;;; Parser
+;;;
+
+(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))))))
+
+(define (parse-quasiquote e 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 (parse-ghil e obj))
+ (make-ghil-unquote-splicing e l (parse-ghil e obj))))
+ (else
+ (list (car x) (parse-quasiquote e 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 (parse-quasiquote e obj (1+ level))))
+ (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+ (else (cons (parse-quasiquote e (car x) level)
+ (parse-quasiquote e (cdr x) level)))))
+
+(define (parse-ghil env exp)
+ (let ((loc (location exp))
+ (retrans (lambda (x) (parse-ghil env x))))
+ (pmatch exp
+ ((ref ,sym) (guard (symbol? sym))
+ (make-ghil-ref env #f (ghil-var-for-ref! env sym)))
+
+ (('quote ,exp) (make-ghil-quote env loc exp))
+
+ ((void) (make-ghil-void env loc))
+
+ ((lambda ,syms ,rest ,meta . ,body)
+ (call-with-ghil-environment env syms
+ (lambda (env vars)
+ (make-ghil-lambda env loc vars rest meta
+ (parse-ghil env `(begin ,@body))))))
+
+ ((begin . ,body)
+ (make-ghil-begin env loc (map retrans body)))
+
+ ((bind ,syms ,exprs . ,body)
+ (let ((vals (map retrans exprs)))
+ (call-with-ghil-bindings env syms
+ (lambda (vars)
+ (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
+
+ ((bindrec ,syms ,exprs . ,body)
+ (call-with-ghil-bindings env syms
+ (lambda (vars)
+ (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
+ (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
+
+ ((set ,sym ,val)
+ (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
+
+ ((define ,sym ,val)
+ (make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
+
+ ((if ,test ,then ,else)
+ (make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
+
+ ((and . ,exps)
+ (make-ghil-and env loc (map retrans exps)))
+
+ ((or . ,exps)
+ (make-ghil-or env loc (map retrans exps)))
+
+ ((mv-bind ,syms ,rest ,producer . ,body)
+ (call-with-ghil-bindings env syms
+ (lambda (vars)
+ (make-ghil-mv-bind env loc (retrans producer) vars rest
+ (map retrans body)))))
+
+ ((call ,proc . ,args)
+ (make-ghil-call env loc (retrans proc) (map retrans args)))
+
+ ((mv-call ,producer ,consumer)
+ (make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
+
+ ((inline ,op . ,args)
+ (make-ghil-inline env loc op (map retrans args)))
+
+ ((values . ,values)
+ (make-ghil-values env loc (map retrans values)))
+
+ ((values* . ,values)
+ (make-ghil-values* env loc (map retrans values)))
+
+ ((compile-time-environment)
+ (make-ghil-reified-env env loc))
+
+ ((quasiquote ,exp)
+ (make-ghil-quasiquote env loc (parse-quasiquote env exp 0)))
+
+ (else
+ (error "unrecognized GHIL" exp)))))
+
+(define (unparse-ghil ghil)
+ (record-case ghil
+ ((<ghil-void> env loc)
+ '(void))
+ ((<ghil-quote> env loc obj)
+ `(,'quote ,obj))
+ ((<ghil-quasiquote> env loc exp)
+ `(,'quasiquote ,(map unparse-ghil exp)))
+ ((<ghil-unquote> env loc exp)
+ `(,'unquote ,(unparse-ghil exp)))
+ ((<ghil-unquote-splicing> env loc exp)
+ `(,'unquote-splicing ,(unparse-ghil exp)))
+ ;; Variables
+ ((<ghil-ref> env loc var)
+ `(ref ,(ghil-var-name var)))
+ ((<ghil-set> env loc var val)
+ `(set ,(ghil-var-name var) ,(unparse-ghil val)))
+ ((<ghil-define> env loc var val)
+ `(define ,(ghil-var-name var) ,(unparse-ghil val)))
+ ;; Controls
+ ((<ghil-if> env loc test then else)
+ `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
+ ((<ghil-and> env loc exps)
+ `(and ,@(map unparse-ghil exps)))
+ ((<ghil-or> env loc exps)
+ `(or ,@(map unparse-ghil exps)))
+ ((<ghil-begin> env loc exps)
+ `(begin ,@(map unparse-ghil exps)))
+ ((<ghil-bind> env loc vars vals body)
+ `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
+ ,(unparse-ghil body)))
+ ((<ghil-mv-bind> env loc producer vars rest body)
+ `(mv-bind ,(map ghil-var-name vars) ,rest
+ ,(unparse-ghil producer) ,(unparse-ghil body)))
+ ((<ghil-lambda> env loc vars rest meta body)
+ `(lambda ,(map ghil-var-name vars) ,rest ,meta
+ ,(unparse-ghil body)))
+ ((<ghil-call> env loc proc args)
+ `(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
+ ((<ghil-mv-call> env loc producer consumer)
+ `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
+ ((<ghil-inline> env loc inline args)
+ `(inline ,inline ,@(map unparse-ghil args)))
+ ((<ghil-values> env loc values)
+ `(values ,@(map unparse-ghil values)))
+ ((<ghil-values*> env loc values)
+ `(values* ,@(map unparse-ghil values)))
+ ((<ghil-reified-env> env loc)
+ `(compile-time-environment))))
--- /dev/null
+;;; GHIL -> GLIL compiler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language ghil compile-glil)
+ #:use-syntax (system base syntax)
+ #:use-module (language glil)
+ #:use-module (language ghil)
+ #:use-module (ice-9 common-list)
+ #:export (compile-glil))
+
+(define (compile-glil x e opts)
+ (if (memq #:O opts) (set! x (optimize x)))
+ (values (codegen x)
+ (and e (cons (car e) (cddr e)))))
+
+\f
+;;;
+;;; 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))))
+
+;; The premise of this, unused, approach to optimization is that you can
+;; determine the environment of a variable lexically, because they have
+;; been alpha-renamed. It makes the transformations *much* easier.
+;; Unfortunately it doesn't work yet.
+(define (optimize* x)
+ (transform-record (<ghil> env loc) x
+ ((quasiquote exp)
+ (define (optimize-qq x)
+ (cond ((list? x) (map optimize-qq x))
+ ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
+ ((record? x) (optimize x))
+ (else x)))
+ (-> (quasiquote (optimize-qq x))))
+
+ ((unquote exp)
+ (-> (unquote (optimize exp))))
+
+ ((unquote-splicing exp)
+ (-> (unquote-splicing (optimize exp))))
+
+ ((set var val)
+ (-> (set var (optimize val))))
+
+ ((define var val)
+ (-> (define var (optimize val))))
+
+ ((if test then else)
+ (-> (if (optimize test) (optimize then) (optimize else))))
+
+ ((and exps)
+ (-> (and (map optimize exps))))
+
+ ((or exps)
+ (-> (or (map optimize exps))))
+
+ ((begin exps)
+ (-> (begin (map optimize exps))))
+
+ ((bind vars vals body)
+ (-> (bind vars (map optimize vals) (optimize body))))
+
+ ((mv-bind producer vars rest body)
+ (-> (mv-bind (optimize producer) vars rest (optimize body))))
+
+ ((inline inst args)
+ (-> (inline inst (map optimize args))))
+
+ ((call (proc (lambda vars (rest #f) meta body)) args)
+ (-> (bind vars (optimize args) (optimize body))))
+
+ ((call proc args)
+ (-> (call (optimize proc) (map optimize args))))
+
+ ((lambda vars rest meta body)
+ (-> (lambda vars rest meta (optimize body))))
+
+ ((mv-call producer (consumer (lambda vars rest meta body)))
+ (-> (mv-bind (optimize producer) vars rest (optimize body))))
+
+ ((mv-call producer consumer)
+ (-> (mv-call (optimize producer) (optimize consumer))))
+
+ ((values values)
+ (-> (values (map optimize values))))
+
+ ((values* values)
+ (-> (values* (map optimize values))))
+
+ (else
+ (error "unrecognized GHIL" x))))
+
+(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)))
+
+\f
+;;;
+;;; Stage 3: Code generation
+;;;
+
+(define *ia-void* (make-glil-void))
+(define *ia-drop* (make-glil-call 'drop 1))
+(define *ia-return* (make-glil-call 'return 1))
+
+(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)))
+ ;;
+ ;; 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) (in-car? #f))
+ (cond
+ ((list? x)
+ (push-call! #f 'mark '())
+ (for-each (lambda (x) (loop x #t)) x)
+ (push-call! #f 'list-mark '()))
+ ((pair? x)
+ (push-call! #f 'mark '())
+ (loop (car x) #t)
+ (loop (cdr x) #f)
+ (push-call! #f 'cons-mark '()))
+ ((record? x)
+ (record-case x
+ ((<ghil-unquote> env loc exp)
+ (comp-push exp))
+ ((<ghil-unquote-splicing> env loc exp)
+ (if (not in-car?)
+ (error "unquote-splicing in the cdr of a pair" exp))
+ (comp-push exp)
+ (push-call! #f 'list-break '()))))
+ ((constant? x)
+ (push-code! #f (make-glil-const x)))
+ (else
+ (error "element of quasiquote can't be compiled" x))))
+ (maybe-drop)
+ (maybe-return))
+
+ ((<ghil-unquote> env loc exp)
+ (error "unquote outside of quasiquote" exp))
+
+ ((<ghil-unquote-splicing> env loc exp)
+ (error "unquote-splicing outside of quasiquote" exp))
+
+ ((<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-code! loc (make-glil-call 'drop 1)))
+ (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 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 'values))
+ (push-code! #f (make-glil-call 'link-now 1))
+ (push-code! #f (make-glil-call 'variable-ref 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 'values))
+ (push-code! #f (make-glil-call 'link-now 1))
+ (push-code! #f (make-glil-call 'variable-ref 0))
+ (push-call! loc 'apply values))))
+
+ ((<ghil-call> env loc proc args)
+ ;; PROC
+ ;; ARGS...
+ ;; ([tail-]call NARGS)
+ (comp-push proc)
+ (let ((nargs (length args)))
+ (cond ((< nargs 255)
+ (push-call! loc (if tail 'goto/args 'call) args))
+ (else
+ (push-call! loc 'mark '())
+ (for-each comp-push args)
+ (push-call! loc 'list-mark '())
+ (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
+ (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)))))
+
+ ((<ghil-reified-env> env loc)
+ (return-object! loc (ghil-env-reify env)))))
+
+ ;;
+ ;; 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))
+ (nargs (allocate-indices-linearly! vars))
+ (nlocs (allocate-locals! locs body))
+ (nexts (allocate-indices-linearly! exts)))
+ ;; meta bindings
+ (push-bindings! #f vars)
+ ;; copy args to the heap if they're marked as external
+ (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)))))))
+ ;; push on definition source location
+ (if loc (set! stack (cons (make-glil-source loc) stack)))
+ ;; compile body
+ (comp body #t #f)
+ ;; create GLIL
+ (make-glil-program nargs (if rest 1 0) nlocs nexts meta
+ (reverse! stack)))))))
+
+(define (allocate-indices-linearly! vars)
+ (do ((n 0 (1+ n))
+ (l vars (cdr l)))
+ ((null? l) n)
+ (let ((v (car l))) (set! (ghil-var-index v) n))))
+
+(define (allocate-locals! vars body)
+ (let ((free '()) (nlocs 0))
+ (define (allocate! var)
+ (cond
+ ((pair? free)
+ (set! (ghil-var-index var) (car free))
+ (set! free (cdr free)))
+ (else
+ (set! (ghil-var-index var) nlocs)
+ (set! nlocs (1+ nlocs)))))
+ (define (deallocate! var)
+ (set! free (cons (ghil-var-index var) free)))
+ (let lp ((x body))
+ (record-case x
+ ((<ghil-void>))
+ ((<ghil-quote>))
+ ((<ghil-quasiquote> exp)
+ (let qlp ((x exp))
+ (cond ((list? x) (for-each qlp x))
+ ((pair? x) (qlp (car x)) (qlp (cdr x)))
+ ((record? x)
+ (record-case x
+ ((<ghil-unquote> exp) (lp exp))
+ ((<ghil-unquote-splicing> exp) (lp exp)))))))
+ ((<ghil-unquote> exp)
+ (lp exp))
+ ((<ghil-unquote-splicing> exp)
+ (lp exp))
+ ((<ghil-reified-env>))
+ ((<ghil-set> val)
+ (lp val))
+ ((<ghil-ref>))
+ ((<ghil-define> val)
+ (lp val))
+ ((<ghil-if> test then else)
+ (lp test) (lp then) (lp else))
+ ((<ghil-and> exps)
+ (for-each lp exps))
+ ((<ghil-or> exps)
+ (for-each lp exps))
+ ((<ghil-begin> exps)
+ (for-each lp exps))
+ ((<ghil-bind> vars vals body)
+ (for-each allocate! vars)
+ (for-each lp vals)
+ (lp body)
+ (for-each deallocate! vars))
+ ((<ghil-mv-bind> vars producer body)
+ (lp producer)
+ (for-each allocate! vars)
+ (lp body)
+ (for-each deallocate! vars))
+ ((<ghil-inline> args)
+ (for-each lp args))
+ ((<ghil-call> proc args)
+ (lp proc)
+ (for-each lp args))
+ ((<ghil-lambda>))
+ ((<ghil-mv-call> producer consumer)
+ (lp producer)
+ (lp consumer))
+ ((<ghil-values> values)
+ (for-each lp values))
+ ((<ghil-values*> values)
+ (for-each lp values))))
+ nlocs))
--- /dev/null
+;;; Guile High Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language ghil spec)
+ #:use-module (system base language)
+ #:use-module (language glil)
+ #:use-module (language ghil)
+ #:use-module (language ghil compile-glil)
+ #:export (ghil))
+
+(define (write-ghil exp . port)
+ (apply write (unparse-ghil exp) port))
+
+(define (parse x)
+ (call-with-ghil-environment (make-ghil-toplevel-env (current-module)) '()
+ (lambda (env vars)
+ (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
+
+(define-language ghil
+ #:title "Guile High Intermediate Language (GHIL)"
+ #:version "0.3"
+ #:reader read
+ #:printer write-ghil
+ #:parser parse
+ #:compilers `((glil . ,compile-glil))
+ )
--- /dev/null
+;;; Guile Low Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language glil)
+ #:use-module (system base syntax)
+ #:use-module (system base pmatch)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export
+ (<glil-program> make-glil-program glil-program?
+ glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
+ glil-program-meta glil-program-body glil-program-closure-level
+
+ <glil-bind> make-glil-bind glil-bind?
+ glil-bind-vars
+
+ <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
+ glil-mv-bind-vars glil-mv-bind-rest
+
+ <glil-unbind> make-glil-unbind glil-unbind?
+
+ <glil-source> make-glil-source glil-source?
+ glil-source-props
+
+ <glil-void> make-glil-void glil-void?
+
+ <glil-const> make-glil-const glil-const?
+ glil-const-obj
+
+ <glil-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
+
+ parse-glil unparse-glil))
+
+(define (print-glil x port)
+ (format port "#<glil ~s>" (unparse-glil x)))
+
+(define-type (<glil> #:printer print-glil)
+ ;; Meta operations
+ (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
+ (<glil-bind> vars)
+ (<glil-mv-bind> vars rest)
+ (<glil-unbind>)
+ (<glil-source> props)
+ ;; 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))
+
+(define (compute-closure-level body)
+ (fold (lambda (x ret)
+ (record-case x
+ ((<glil-program> closure-level) (max ret closure-level))
+ ((<glil-external> depth) (max ret depth))
+ (else ret)))
+ 0 body))
+
+(define %make-glil-program make-glil-program)
+(define (make-glil-program . args)
+ (let ((prog (apply %make-glil-program args)))
+ (if (not (glil-program-closure-level prog))
+ (set! (glil-program-closure-level prog)
+ (compute-closure-level (glil-program-body prog))))
+ prog))
+
+\f
+(define (parse-glil x)
+ (pmatch x
+ ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
+ (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
+ ((bind . ,vars) (make-glil-bind vars))
+ ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
+ ((unbind) (make-glil-unbind))
+ ((source ,props) (make-glil-source props))
+ ((void) (make-glil-void))
+ ((const ,obj) (make-glil-const obj))
+ ((argument ,op ,index) (make-glil-argument op index))
+ ((local ,op ,index) (make-glil-local op index))
+ ((external ,op ,depth ,index) (make-glil-external op depth index))
+ ((toplevel ,op ,name) (make-glil-toplevel op name))
+ ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
+ ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
+ ((label ,label) (make-label ,label))
+ ((branch ,inst ,label) (make-glil-branch inst label))
+ ((call ,inst ,nargs) (make-glil-call inst nargs))
+ ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
+ (else (error "invalid glil" x))))
+
+(define (unparse-glil glil)
+ (record-case glil
+ ;; meta
+ ((<glil-program> nargs nrest nlocs nexts meta body)
+ `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
+ ((<glil-bind> vars) `(bind ,@vars))
+ ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
+ ((<glil-unbind>) `(unbind))
+ ((<glil-source> props) `(source ,props))
+ ;; constants
+ ((<glil-void>) `(void))
+ ((<glil-const> obj) `(const ,obj))
+ ;; variables
+ ((<glil-argument> op index)
+ `(argument ,op ,index))
+ ((<glil-local> op index)
+ `(local ,op ,index))
+ ((<glil-external> op depth index)
+ `(external ,op ,depth ,index))
+ ((<glil-toplevel> op name)
+ `(toplevel ,op ,name))
+ ((<glil-module> op mod name public?)
+ `(module ,(if public? 'public 'private) ,op ,mod ,name))
+ ;; controls
+ ((<glil-label> label) `(label ,label))
+ ((<glil-branch> inst label) `(branch ,inst ,label))
+ ((<glil-call> inst nargs) `(call ,inst ,nargs))
+ ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))))
--- /dev/null
+;;; Guile VM assembler
+
+;; Copyright (C) 2001, 2009 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 glil compile-assembly)
+ #:use-module (system base syntax)
+ #:use-module (system base pmatch)
+ #:use-module (language glil)
+ #:use-module (language assembly)
+ #:use-module (system vm instruction)
+ #:use-module ((system vm program) #:select (make-binding))
+ #:use-module (ice-9 receive)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export (compile-assembly))
+
+;; Variable cache cells go in the object table, and serialize as their
+;; keys. The reason we wrap the keys in these records is so they don't
+;; compare as `equal?' to other objects in the object table.
+;;
+;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
+
+(define-record <variable-cache-cell> key)
+
+;; Subprograms can be loaded into an object table as well. We need a
+;; disjoint type here too. (Subprograms have their own object tables --
+;; though probably we should just make one table per compilation unit.)
+
+(define-record <subprogram> table prog)
+
+
+(define (limn-sources sources)
+ (let lp ((in sources) (out '()) (filename #f))
+ (if (null? in)
+ (reverse! out)
+ (let ((addr (caar in))
+ (new-filename (assq-ref (cdar in ) 'filename))
+ (line (assq-ref (cdar in) 'line))
+ (column (assq-ref (cdar in) 'column)))
+ (cond
+ ((not (equal? new-filename filename))
+ (lp (cdr in)
+ `((,addr . (,line . ,column))
+ (filename ,new-filename)
+ . ,out)
+ new-filename))
+ ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
+ (lp (cdr in)
+ `((,addr . (,line . ,column))
+ . ,out)
+ filename))
+ (else
+ (lp (cdr in) out filename)))))))
+
+(define (make-meta bindings sources tail)
+ (if (and (null? bindings) (null? sources) (null? tail))
+ #f
+ (compile-assembly
+ (make-glil-program 0 0 0 0 '()
+ (list
+ (make-glil-const `(,bindings ,sources ,@tail))
+ (make-glil-call 'return 1))))))
+
+;; A functional stack of names of live variables.
+(define (make-open-binding name ext? index)
+ (list name ext? index))
+(define (make-closed-binding open-binding start end)
+ (make-binding (car open-binding) (cadr open-binding)
+ (caddr open-binding) start end))
+(define (open-binding bindings vars nargs start)
+ (cons
+ (acons start
+ (map
+ (lambda (v)
+ (pmatch v
+ ((,name argument ,i) (make-open-binding name #f i))
+ ((,name local ,i) (make-open-binding name #f (+ nargs i)))
+ ((,name external ,i) (make-open-binding name #t i))
+ (else (error "unknown binding type" name type))))
+ vars)
+ (car bindings))
+ (cdr bindings)))
+(define (close-binding bindings end)
+ (pmatch bindings
+ ((((,start . ,closing) . ,open) . ,closed)
+ (cons open
+ (fold (lambda (o tail)
+ ;; the cons is for dsu sort
+ (acons start (make-closed-binding o start end)
+ tail))
+ closed
+ closing)))
+ (else (error "broken bindings" bindings))))
+(define (close-all-bindings bindings end)
+ (if (null? (car bindings))
+ (map cdr
+ (stable-sort (reverse (cdr bindings))
+ (lambda (x y) (< (car x) (car y)))))
+ (close-all-bindings (close-binding bindings end) end)))
+
+;; A functional object table.
+(define *module* 1)
+(define (assoc-ref-or-acons alist x make-y)
+ (cond ((assoc-ref alist x)
+ => (lambda (y) (values y alist)))
+ (else
+ (let ((y (make-y x alist)))
+ (values y (acons x y alist))))))
+(define (object-index-and-alist x alist)
+ (assoc-ref-or-acons alist x
+ (lambda (x alist)
+ (+ (length alist) *module*))))
+
+(define (compile-assembly glil)
+ (receive (code . _)
+ (glil->assembly glil 0 '() '(()) '() '() #f -1)
+ (car code)))
+(define (make-object-table objects)
+ (and (not (null? objects))
+ (list->vector (cons #f objects))))
+
+(define (glil->assembly glil nargs nexts-stack bindings
+ source-alist label-alist object-alist addr)
+ (define (emit-code x)
+ (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+ (define (emit-code/object x object-alist)
+ (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+
+ (record-case glil
+ ((<glil-program> nargs nrest nlocs nexts meta body closure-level)
+ (let ((toplevel? (null? nexts-stack)))
+ (define (process-body)
+ (let ((nexts-stack (cons nexts nexts-stack)))
+ (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+ (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ (cond
+ ((null? body)
+ (values (reverse code)
+ (close-all-bindings bindings addr)
+ (limn-sources (reverse! source-alist))
+ (reverse label-alist)
+ (and object-alist (map car (reverse object-alist)))
+ addr))
+ (else
+ (receive (subcode bindings source-alist label-alist object-alist)
+ (glil->assembly (car body) nargs nexts-stack bindings
+ source-alist label-alist object-alist addr)
+ (lp (cdr body) (append (reverse subcode) code)
+ bindings source-alist label-alist object-alist
+ (addr+ addr subcode))))))))
+
+ (receive (code bindings sources labels objects len)
+ (process-body)
+ (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
+ ,len
+ ,(make-meta bindings sources meta)
+ . ,code)))
+ (cond
+ (toplevel?
+ ;; toplevel bytecode isn't loaded by the vm, no way to do
+ ;; object table or closure capture (not in the bytecode,
+ ;; anyway)
+ (emit-code (align-program prog addr)))
+ (else
+ (let ((table (dump-object (make-object-table objects) addr))
+ (closure (if (> closure-level 0) '((make-closure)) '())))
+ (cond
+ (object-alist
+ ;; if we are being compiled from something with an object
+ ;; table, cache the program there
+ (receive (i object-alist)
+ (object-index-and-alist (make-subprogram table prog)
+ object-alist)
+ (emit-code/object `((object-ref ,i) ,@closure)
+ object-alist)))
+ (else
+ ;; otherwise emit a load directly
+ (emit-code `(,@table ,@(align-program prog (addr+ addr table))
+ ,@closure)))))))))))
+
+ ((<glil-bind> vars)
+ (values '()
+ (open-binding bindings vars nargs addr)
+ source-alist
+ label-alist
+ object-alist))
+
+ ((<glil-mv-bind> vars rest)
+ (values `((truncate-values ,(length vars) ,(if rest 1 0)))
+ (open-binding bindings vars nargs addr)
+ source-alist
+ label-alist
+ object-alist))
+
+ ((<glil-unbind>)
+ (values '()
+ (close-binding bindings addr)
+ source-alist
+ label-alist
+ object-alist))
+
+ ((<glil-source> props)
+ (values '()
+ bindings
+ (acons addr props source-alist)
+ label-alist
+ object-alist))
+
+ ((<glil-void>)
+ (emit-code '((void))))
+
+ ((<glil-const> obj)
+ (cond
+ ((object->assembly obj)
+ => (lambda (code)
+ (emit-code (list code))))
+ ((not object-alist)
+ (emit-code (dump-object obj addr)))
+ (else
+ (receive (i object-alist)
+ (object-index-and-alist obj object-alist)
+ (emit-code/object `((object-ref ,i))
+ object-alist)))))
+
+ ((<glil-argument> op index)
+ (emit-code (if (eq? op 'ref)
+ `((local-ref ,index))
+ `((local-set ,index)))))
+
+ ((<glil-local> op index)
+ (emit-code (if (eq? op 'ref)
+ `((local-ref ,(+ nargs index)))
+ `((local-set ,(+ nargs index))))))
+
+ ((<glil-external> op depth index)
+ (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
+ (if (> d 0)
+ (lp (1- d) (+ n (car stack)) (cdr stack))
+ (if (eq? op 'ref)
+ `((external-ref ,(+ n index)))
+ `((external-set ,(+ n index))))))))
+
+ ((<glil-toplevel> op name)
+ (case op
+ ((ref set)
+ (cond
+ ((not object-alist)
+ (emit-code `(,@(dump-object name addr)
+ (link-now)
+ ,(case op
+ ((ref) '(variable-ref))
+ ((set) '(variable-set))))))
+ (else
+ (receive (i object-alist)
+ (object-index-and-alist (make-variable-cache-cell name)
+ object-alist)
+ (emit-code/object (case op
+ ((ref) `((toplevel-ref ,i)))
+ ((set) `((toplevel-set ,i))))
+ object-alist)))))
+ ((define)
+ (emit-code `((define ,(symbol->string name))
+ (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
+ ((not object-alist)
+ (emit-code `(,@(dump-object key addr)
+ (link-now)
+ ,(case op
+ ((ref) '(variable-ref))
+ ((set) '(variable-set))))))
+ (else
+ (receive (i object-alist)
+ (object-index-and-alist (make-variable-cache-cell key)
+ object-alist)
+ (emit-code/object (case op
+ ((ref) `((toplevel-ref ,i)))
+ ((set) `((toplevel-set ,i))))
+ object-alist)))))
+ (else
+ (error "unknown module var kind" op key)))))
+
+ ((<glil-label> label)
+ (values '()
+ bindings
+ source-alist
+ (acons label addr label-alist)
+ object-alist))
+
+ ((<glil-branch> inst label)
+ (emit-code `((,inst ,label))))
+
+ ;; nargs is number of stack args to insn. probably should rename.
+ ((<glil-call> inst nargs)
+ (if (not (instruction? inst))
+ (error "Unknown instruction:" inst))
+ (let ((pops (instruction-pops inst)))
+ (cond ((< pops 0)
+ (emit-code `((,inst ,nargs))))
+ ((= pops nargs)
+ (emit-code `((,inst))))
+ (else
+ (error "Wrong number of stack arguments to instruction:" inst nargs)))))
+
+ ((<glil-mv-call> nargs ra)
+ (emit-code `((mv-call ,nargs ,ra))))))
+
+(define (dump-object x addr)
+ (define (too-long x)
+ (error (string-append x " too long")))
+
+ (cond
+ ((object->assembly x) => list)
+ ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
+ ((subprogram? x)
+ `(,@(subprogram-table x)
+ ,@(align-program (subprogram-prog x)
+ (addr+ addr (subprogram-table x)))))
+ ((and (integer? x) (exact? x))
+ (let ((str (do ((n x (quotient n 256))
+ (l '() (cons (modulo n 256) l)))
+ ((= n 0)
+ (list->string (map integer->char l))))))
+ (if (< x 0)
+ `((load-integer ,str))
+ `((load-unsigned-integer ,str)))))
+ ((number? x)
+ `((load-number ,(number->string x))))
+ ((string? x)
+ `((load-string ,x)))
+ ((symbol? x)
+ `((load-symbol ,(symbol->string x))))
+ ((keyword? x)
+ `((load-keyword ,(symbol->string (keyword->symbol x)))))
+ ((list? x)
+ (let ((tail (let ((len (length x)))
+ (if (>= len 65536) (too-long "list"))
+ `((list ,(quotient len 256) ,(modulo len 256))))))
+ (let dump-objects ((objects x) (codes '()) (addr addr))
+ (if (null? objects)
+ (fold append tail codes)
+ (let ((code (dump-object (car objects) addr)))
+ (dump-objects (cdr objects) (cons code codes)
+ (addr+ addr code)))))))
+ ((pair? x)
+ (let ((kar (dump-object (car x) addr)))
+ `(,@kar
+ ,@(dump-object (cdr x) (addr+ addr kar))
+ (cons))))
+ ((vector? x)
+ (let* ((len (vector-length x))
+ (tail (if (>= len 65536)
+ (too-long "vector")
+ `((vector ,(quotient len 256) ,(modulo len 256))))))
+ (let dump-objects ((i 0) (codes '()) (addr addr))
+ (if (>= i len)
+ (fold append tail codes)
+ (let ((code (dump-object (vector-ref x i) addr)))
+ (dump-objects (1+ i) (cons code codes)
+ (addr+ addr code)))))))
+ (else
+ (error "assemble: unrecognized object" x))))
+
--- /dev/null
+;;; Guile Lowlevel 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 glil spec)
+ #:use-module (system base language)
+ #:use-module (language glil)
+ #:use-module (language glil compile-assembly)
+ #:export (glil))
+
+(define (write-glil exp . port)
+ (apply write (unparse-glil exp) port))
+
+(define (compile-asm x e opts)
+ (values (compile-assembly x) e))
+
+(define-language glil
+ #:title "Guile Lowlevel Intermediate Language (GLIL)"
+ #:version "0.3"
+ #:reader read
+ #:printer write-glil
+ #:parser parse-glil
+ #:compilers `((assembly . ,compile-asm))
+ )
--- /dev/null
+;;; Guile Virtual Machine 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 (language objcode)
+ #:export (encode-length decode-length))
+
+\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 ((x (pop)))
+ (cond ((< x 254) x)
+ ((= x 254) (+ (ash x 8) (pop)))
+ (else
+ (let* ((b2 (pop))
+ (b3 (pop))
+ (b4 (pop)))
+ (+ (ash x 24) (ash b2 16) (ash b3 8) b4))))))
--- /dev/null
+;;; Guile Lowlevel 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 objcode spec)
+ #:use-module (system base language)
+ #:use-module (system vm objcode)
+ #:use-module (system vm program)
+ #:export (objcode make-objcode-env))
+
+(define (make-objcode-env module externals)
+ (cons module externals))
+
+(define (objcode-env-module env)
+ (if env (car env) (current-module)))
+
+(define (objcode-env-externals env)
+ (if env (cdr env) '()))
+
+(define (objcode->value x e opts)
+ (let ((thunk (make-program x #f (objcode-env-externals e))))
+ (if e
+ (save-module-excursion
+ (lambda ()
+ (set-current-module (objcode-env-module e))
+ (values (thunk) #f)))
+ (values (thunk) #f))))
+
+;; since locals are allocated on the stack and can have limited scope,
+;; in many cases we use one local for more than one lexical variable. so
+;; the returned locals set is a list, where element N of the list is
+;; itself a list of bindings for local variable N.
+(define (collapse-locals locs)
+ (let lp ((ret '()) (locs locs))
+ (if (null? locs)
+ (map cdr (sort! ret
+ (lambda (x y) (< (car x) (car y)))))
+ (let ((b (car locs)))
+ (cond
+ ((assv-ref ret (binding:index b))
+ => (lambda (bindings)
+ (append! bindings (list b))
+ (lp ret (cdr locs))))
+ (else
+ (lp (acons (binding:index b) (list b) ret)
+ (cdr locs))))))))
+
+(define (decompile-value x env opts)
+ (cond
+ ((program? x)
+ (let ((objs (program-objects x))
+ (meta (program-meta x))
+ (exts (program-external x))
+ (binds (program-bindings x))
+ (srcs (program-sources x))
+ (nargs (arity:nargs (program-arity x))))
+ (let ((blocs (and binds
+ (collapse-locals
+ (append (list-head binds nargs)
+ (filter (lambda (x) (not (binding:extp x)))
+ (list-tail binds nargs))))))
+ (bexts (and binds
+ (filter binding:extp binds))))
+ (values (program-objcode x)
+ `((objects . ,objs)
+ (meta . ,(and meta (meta)))
+ (exts . ,exts)
+ (blocs . ,blocs)
+ (bexts . ,bexts)
+ (sources . ,srcs))))))
+ ((objcode? x)
+ (values x #f))
+ (else
+ (error "can't decompile ~A: not a program or objcode" x))))
+
+(define-language objcode
+ #:title "Guile Object Code"
+ #:version "0.3"
+ #:reader #f
+ #:printer write-objcode
+ #:compilers `((value . ,objcode->value))
+ #:decompilers `((value . ,decompile-value))
+ )
--- /dev/null
+;;; R5RS core environment
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+;; Non standard procedures
+
+(@define void (@lambda () (@void)))
+
+;; 6. Standard procedures
+
+;;; 6.1 Equivalence predicates
+
+(@define eq? (@lambda (x y) (@eq? x y)))
+(@define eqv? (@ Core::eqv?))
+(@define equal? (@ Core::equal?))
+
+;;; 6.2 Numbers
+
+(@define number? (@ Core::number?))
+(@define complex? (@ Core::complex?))
+(@define real? (@ Core::real?))
+(@define rational? (@ Core::rational?))
+(@define integer? (@ Core::integer?))
+
+(@define exact? (@ Core::exact?))
+(@define inexact? (@ Core::inexact?))
+
+(@define = (@ Core::=))
+(@define < (@ Core::<))
+(@define > (@ Core::>))
+(@define <= (@ Core::<=))
+(@define >= (@ Core::>=))
+
+(@define zero? (@ Core::zero?))
+(@define positive? (@ Core::positive?))
+(@define negative? (@ Core::negative?))
+(@define odd? (@ Core::odd?))
+(@define even? (@ Core::even?))
+
+(@define max (@ Core::max))
+(@define min (@ Core::min))
+
+(@define + (@ Core::+))
+(@define * (@ Core::*))
+(@define - (@ Core::-))
+(@define / (@ Core::/))
+
+(@define abs (@ Core::abs))
+
+(@define quotient (@ Core::quotient))
+(@define remainder (@ Core::remainder))
+(@define modulo (@ Core::modulo))
+
+(@define gcd (@ Core::gcd))
+(@define lcm (@ Core::lcm))
+
+;; (@define numerator (@ Core::numerator))
+;; (@define denominator (@ Core::denominator))
+
+(@define floor (@ Core::floor))
+(@define ceiling (@ Core::ceiling))
+(@define truncate (@ Core::truncate))
+(@define round (@ Core::round))
+
+;; (@define rationalize (@ Core::rationalize))
+
+(@define exp (@ Core::exp))
+(@define log (@ Core::log))
+(@define sin (@ Core::sin))
+(@define cos (@ Core::cos))
+(@define tan (@ Core::tan))
+(@define asin (@ Core::asin))
+(@define acos (@ Core::acos))
+(@define atan (@ Core::atan))
+
+(@define sqrt (@ Core::sqrt))
+(@define expt (@ Core::expt))
+
+(@define make-rectangular (@ Core::make-rectangular))
+(@define make-polar (@ Core::make-polar))
+(@define real-part (@ Core::real-part))
+(@define imag-part (@ Core::imag-part))
+(@define magnitude (@ Core::magnitude))
+(@define angle (@ Core::angle))
+
+(@define exact->inexact (@ Core::exact->inexact))
+(@define inexact->exact (@ Core::inexact->exact))
+
+(@define number->string (@ Core::number->string))
+(@define string->number (@ Core::string->number))
+
+;;; 6.3 Other data types
+
+;;;; 6.3.1 Booleans
+
+(@define not (@lambda (x) (@not x)))
+(@define boolean? (@ Core::boolean?))
+
+;;;; 6.3.2 Pairs and lists
+
+(@define pair? (@lambda (x) (@pair? x)))
+(@define cons (@lambda (x y) (@cons x y)))
+
+(@define car (@lambda (x) (@car x)))
+(@define cdr (@lambda (x) (@cdr x)))
+(@define set-car! (@ Core::set-car!))
+(@define set-cdr! (@ Core::set-cdr!))
+
+(@define caar (@lambda (x) (@caar x)))
+(@define cadr (@lambda (x) (@cadr x)))
+(@define cdar (@lambda (x) (@cdar x)))
+(@define cddr (@lambda (x) (@cddr x)))
+(@define caaar (@lambda (x) (@caaar x)))
+(@define caadr (@lambda (x) (@caadr x)))
+(@define cadar (@lambda (x) (@cadar x)))
+(@define caddr (@lambda (x) (@caddr x)))
+(@define cdaar (@lambda (x) (@cdaar x)))
+(@define cdadr (@lambda (x) (@cdadr x)))
+(@define cddar (@lambda (x) (@cddar x)))
+(@define cdddr (@lambda (x) (@cdddr x)))
+(@define caaaar (@lambda (x) (@caaaar x)))
+(@define caaadr (@lambda (x) (@caaadr x)))
+(@define caadar (@lambda (x) (@caadar x)))
+(@define caaddr (@lambda (x) (@caaddr x)))
+(@define cadaar (@lambda (x) (@cadaar x)))
+(@define cadadr (@lambda (x) (@cadadr x)))
+(@define caddar (@lambda (x) (@caddar x)))
+(@define cadddr (@lambda (x) (@cadddr x)))
+(@define cdaaar (@lambda (x) (@cdaaar x)))
+(@define cdaadr (@lambda (x) (@cdaadr x)))
+(@define cdadar (@lambda (x) (@cdadar x)))
+(@define cdaddr (@lambda (x) (@cdaddr x)))
+(@define cddaar (@lambda (x) (@cddaar x)))
+(@define cddadr (@lambda (x) (@cddadr x)))
+(@define cdddar (@lambda (x) (@cdddar x)))
+(@define cddddr (@lambda (x) (@cddddr x)))
+
+(@define null? (@lambda (x) (@null? x)))
+(@define list? (@lambda (x) (@list? x)))
+
+(@define list (@lambda x x))
+
+(@define length (@ Core::length))
+(@define append (@ Core::append))
+(@define reverse (@ Core::reverse))
+(@define list-tail (@ Core::list-tail))
+(@define list-ref (@ Core::list-ref))
+
+(@define memq (@ Core::memq))
+(@define memv (@ Core::memv))
+(@define member (@ Core::member))
+
+(@define assq (@ Core::assq))
+(@define assv (@ Core::assv))
+(@define assoc (@ Core::assoc))
+
+;;;; 6.3.3 Symbols
+
+(@define symbol? (@ Core::symbol?))
+(@define symbol->string (@ Core::symbol->string))
+(@define string->symbol (@ Core::string->symbol))
+
+;;;; 6.3.4 Characters
+
+(@define char? (@ Core::char?))
+(@define char=? (@ Core::char=?))
+(@define char<? (@ Core::char<?))
+(@define char>? (@ Core::char>?))
+(@define char<=? (@ Core::char<=?))
+(@define char>=? (@ Core::char>=?))
+(@define char-ci=? (@ Core::char-ci=?))
+(@define char-ci<? (@ Core::char-ci<?))
+(@define char-ci>? (@ Core::char-ci>?))
+(@define char-ci<=? (@ Core::char-ci<=?))
+(@define char-ci>=? (@ Core::char-ci>=?))
+(@define char-alphabetic? (@ Core::char-alphabetic?))
+(@define char-numeric? (@ Core::char-numeric?))
+(@define char-whitespace? (@ Core::char-whitespace?))
+(@define char-upper-case? (@ Core::char-upper-case?))
+(@define char-lower-case? (@ Core::char-lower-case?))
+(@define char->integer (@ Core::char->integer))
+(@define integer->char (@ Core::integer->char))
+(@define char-upcase (@ Core::char-upcase))
+(@define char-downcase (@ Core::char-downcase))
+
+;;;; 6.3.5 Strings
+
+(@define string? (@ Core::string?))
+(@define make-string (@ Core::make-string))
+(@define string (@ Core::string))
+(@define string-length (@ Core::string-length))
+(@define string-ref (@ Core::string-ref))
+(@define string-set! (@ Core::string-set!))
+
+(@define string=? (@ Core::string=?))
+(@define string-ci=? (@ Core::string-ci=?))
+(@define string<? (@ Core::string<?))
+(@define string>? (@ Core::string>?))
+(@define string<=? (@ Core::string<=?))
+(@define string>=? (@ Core::string>=?))
+(@define string-ci<? (@ Core::string-ci<?))
+(@define string-ci>? (@ Core::string-ci>?))
+(@define string-ci<=? (@ Core::string-ci<=?))
+(@define string-ci>=? (@ Core::string-ci>=?))
+
+(@define substring (@ Core::substring))
+(@define string-append (@ Core::string-append))
+(@define string->list (@ Core::string->list))
+(@define list->string (@ Core::list->string))
+(@define string-copy (@ Core::string-copy))
+(@define string-fill! (@ Core::string-fill!))
+
+;;;; 6.3.6 Vectors
+
+(@define vector? (@ Core::vector?))
+(@define make-vector (@ Core::make-vector))
+(@define vector (@ Core::vector))
+(@define vector-length (@ Core::vector-length))
+(@define vector-ref (@ Core::vector-ref))
+(@define vector-set! (@ Core::vector-set!))
+(@define vector->list (@ Core::vector->list))
+(@define list->vector (@ Core::list->vector))
+(@define vector-fill! (@ Core::vector-fill!))
+
+;;; 6.4 Control features
+
+(@define procedure? (@ Core::procedure?))
+(@define apply (@ Core::apply))
+(@define map (@ Core::map))
+(@define for-each (@ Core::for-each))
+(@define force (@ Core::force))
+
+(@define call-with-current-continuation (@ Core::call-with-current-continuation))
+(@define values (@ Core::values))
+(@define call-with-values (@ Core::call-with-values))
+(@define dynamic-wind (@ Core::dynamic-wind))
+
+;;; 6.5 Eval
+
+(@define eval
+ (@let ((l (@ Language::r5rs::spec::r5rs)))
+ (@lambda (x e)
+ (((@ System::Base::language::compile-in) x e l)))))
+
+;; (@define scheme-report-environment
+;; (@lambda (version)
+;; (@if (@= version 5)
+;; (@ Language::R5RS::Core)
+;; (@error "Unsupported environment version" version))))
+;;
+;; (@define null-environment
+;; (@lambda (version)
+;; (@if (@= version 5)
+;; (@ Language::R5RS::Null)
+;; (@error "Unsupported environment version" version))))
+
+(@define interaction-environment (@lambda () (@current-module)))
+
+;;; 6.6 Input and output
+
+;;;; 6.6.1 Ports
+
+(@define call-with-input-file (@ Core::call-with-input-file))
+(@define call-with-output-file (@ Core::call-with-output-file))
+
+(@define input-port? (@ Core::input-port?))
+(@define output-port? (@ Core::output-port?))
+(@define current-input-port (@ Core::current-input-port))
+(@define current-output-port (@ Core::current-output-port))
+
+(@define with-input-from-file (@ Core::with-input-from-file))
+(@define with-output-to-file (@ Core::with-output-to-file))
+
+(@define open-input-file (@ Core::open-input-file))
+(@define open-output-file (@ Core::open-output-file))
+(@define close-input-port (@ Core::close-input-port))
+(@define close-output-port (@ Core::close-output-port))
+
+;;;; 6.6.2 Input
+
+(@define read (@ Core::read))
+(@define read-char (@ Core::read-char))
+(@define peek-char (@ Core::peek-char))
+(@define eof-object? (@ Core::eof-object?))
+(@define char-ready? (@ Core::char-ready?))
+
+;;;; 6.6.3 Output
+
+(@define write (@ Core::write))
+(@define display (@ Core::display))
+(@define newline (@ Core::newline))
+(@define write-char (@ Core::write-char))
+
+;;;; 6.6.4 System interface
+
+(@define load
+ (@lambda (file)
+ (call-with-input-file file
+ (@lambda (port)
+ (@let ((loop (@lambda (x)
+ (@if (@not (eof-object? x))
+ (@begin
+ (eval x (interaction-environment))
+ (loop (read port)))))))
+ (loop (read port)))))))
+
+;; transcript-on
+;; transcript-off
--- /dev/null
+;;; R5RS syntax expander
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language r5rs expand)
+ #:export (expand void
+ identifier? free-identifier=? bound-identifier=?
+ generate-temporaries datum->syntax-object syntax-object->datum))
+
+(define sc-expand #f)
+(define $sc-put-cte #f)
+(define $syntax-dispatch #f)
+(define syntax-rules #f)
+(define syntax-error #f)
+(define identifier? #f)
+(define free-identifier=? #f)
+(define bound-identifier=? #f)
+(define generate-temporaries #f)
+(define datum->syntax-object #f)
+(define syntax-object->datum #f)
+
+(define void (lambda () (if #f #f)))
+
+(define andmap
+ (lambda (f first . rest)
+ (or (null? first)
+ (if (null? rest)
+ (let andmap ((first first))
+ (let ((x (car first)) (first (cdr first)))
+ (if (null? first)
+ (f x)
+ (and (f x) (andmap first)))))
+ (let andmap ((first first) (rest rest))
+ (let ((x (car first))
+ (xr (map car rest))
+ (first (cdr first))
+ (rest (map cdr rest)))
+ (if (null? first)
+ (apply f (cons x xr))
+ (and (apply f (cons x xr)) (andmap first rest)))))))))
+
+(define ormap
+ (lambda (proc list1)
+ (and (not (null? list1))
+ (or (proc (car list1)) (ormap proc (cdr list1))))))
+
+(define putprop set-symbol-property!)
+(define getprop symbol-property)
+(define remprop symbol-property-remove!)
+
+(define syncase-module (current-module))
+(define guile-eval eval)
+(define (eval x)
+ (if (and (pair? x) (equal? (car x) "noexpand"))
+ (cdr x)
+ (guile-eval x syncase-module)))
+
+(define guile-error error)
+(define (error who format-string why what)
+ (guile-error why what))
+
+(load "psyntax.pp")
+
+(define expand sc-expand)
--- /dev/null
+;;; R5RS null environment
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
--- /dev/null
+;;; psyntax.pp
+;;; automatically generated from psyntax.ss
+;;; Wed Aug 30 12:24:52 EST 2000
+;;; see copyright notice in psyntax.ss
+
+((lambda ()
+ (letrec ((g452
+ (lambda (g1823)
+ ((letrec ((g1824
+ (lambda (g1827 g1825 g1826)
+ (if (pair? g1827)
+ (g1824
+ (cdr g1827)
+ (cons (g393 (car g1827) g1826) g1825)
+ g1826)
+ (if (g256 g1827)
+ (cons (g393 g1827 g1826) g1825)
+ (if (null? g1827)
+ g1825
+ (if (g204 g1827)
+ (g1824
+ (g205 g1827)
+ g1825
+ (g371 g1826 (g206 g1827)))
+ (if (g90 g1827)
+ (g1824
+ (annotation-expression
+ g1827)
+ g1825
+ g1826)
+ (cons g1827 g1825)))))))))
+ g1824)
+ g1823
+ '()
+ '(()))))
+ (g451
+ (lambda (g833)
+ ((lambda (g834) (if (g90 g834) (gensym) (gensym)))
+ (if (g204 g833) (g205 g833) g833))))
+ (g450
+ (lambda (g1820 g1819)
+ (g449 g1820
+ g1819
+ (lambda (g1821)
+ (if ((lambda (g1822)
+ (if g1822
+ g1822
+ (if (pair? g1821)
+ (g90 (car g1821))
+ '#f)))
+ (g90 g1821))
+ (g448 g1821 '#f)
+ g1821)))))
+ (g449
+ (lambda (g837 g835 g836)
+ (if (memq 'top (g264 g835))
+ (g836 g837)
+ ((letrec ((g838
+ (lambda (g839)
+ (if (g204 g839)
+ (g449 (g205 g839) (g206 g839) g836)
+ (if (pair? g839)
+ ((lambda (g841 g840)
+ (if (if (eq? g841 (car g839))
+ (eq? g840 (cdr g839))
+ '#f)
+ g839
+ (cons g841 g840)))
+ (g838 (car g839))
+ (g838 (cdr g839)))
+ (if (vector? g839)
+ ((lambda (g842)
+ ((lambda (g843)
+ (if (andmap
+ eq?
+ g842
+ g843)
+ g839
+ (list->vector g843)))
+ (map g838 g842)))
+ (vector->list g839))
+ g839))))))
+ g838)
+ g837))))
+ (g448
+ (lambda (g1813 g1812)
+ (if (pair? g1813)
+ ((lambda (g1814)
+ (begin (if g1812
+ (set-annotation-stripped! g1812 g1814)
+ (void))
+ (set-car! g1814 (g448 (car g1813) '#f))
+ (set-cdr! g1814 (g448 (cdr g1813) '#f))
+ g1814))
+ (cons '#f '#f))
+ (if (g90 g1813)
+ ((lambda (g1815)
+ (if g1815
+ g1815
+ (g448 (annotation-expression g1813) g1813)))
+ (annotation-stripped g1813))
+ (if (vector? g1813)
+ ((lambda (g1816)
+ (begin (if g1812
+ (set-annotation-stripped!
+ g1812
+ g1816)
+ (void))
+ ((letrec ((g1817
+ (lambda (g1818)
+ (if (not (< g1818 '0))
+ (begin (vector-set!
+ g1816
+ g1818
+ (g448 (vector-ref
+ g1813
+ g1818)
+ '#f))
+ (g1817
+ (- g1818
+ '1)))
+ (void)))))
+ g1817)
+ (- (vector-length g1813) '1))
+ g1816))
+ (make-vector (vector-length g1813)))
+ g1813)))))
+ (g447
+ (lambda (g844)
+ (if (g255 g844)
+ (g378 g844
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage ((import-token . *top*)) () ())
+ #(ribcage ((import-token . *top*)) () ()))))
+ '#f)))
+ (g446 (lambda () (list 'void)))
+ (g445
+ (lambda (g850 g845 g849 g846 g848 g847)
+ ((lambda (g851)
+ ((lambda (g852)
+ (if g852
+ (apply
+ (lambda (g857 g853 g856 g854 g855)
+ ((lambda (g858)
+ (if (not (g389 g858))
+ (g391 (map (lambda (g859)
+ (g393 g859 g846))
+ g858)
+ (g394 g845 g846 g848)
+ '"keyword")
+ ((lambda (g860)
+ ((lambda (g861)
+ (g847 (cons g854 g855)
+ (g247 g860
+ ((lambda (g863 g862)
+ (map (lambda (g865)
+ (g231 'deferred
+ (g432 g865
+ g862
+ g863)))
+ g856))
+ (if g850 g861 g846)
+ (g249 g849))
+ g849)
+ g861
+ g848))
+ (g368 g858 g860 g846)))
+ (g299 g858))))
+ g853))
+ g852)
+ ((lambda (g868)
+ (syntax-error (g394 g845 g846 g848)))
+ g851)))
+ ($syntax-dispatch
+ g851
+ '(any #(each (any any)) any . each-any))))
+ g845)))
+ (g444
+ (lambda (g1789 g1785 g1788 g1786 g1787)
+ ((lambda (g1790)
+ ((lambda (g1791)
+ (if g1791
+ (apply
+ (lambda (g1794 g1792 g1793)
+ ((lambda (g1795)
+ (if (not (g389 g1795))
+ (syntax-error
+ g1789
+ '"invalid parameter list in")
+ ((lambda (g1797 g1796)
+ (g1787
+ g1796
+ (g437 (cons g1792 g1793)
+ g1789
+ (g248 g1797 g1796 g1788)
+ (g368 g1795 g1797 g1786))))
+ (g299 g1795)
+ (map g451 g1795))))
+ g1794))
+ g1791)
+ ((lambda (g1800)
+ (if g1800
+ (apply
+ (lambda (g1803 g1801 g1802)
+ ((lambda (g1804)
+ (if (not (g389 g1804))
+ (syntax-error
+ g1789
+ '"invalid parameter list in")
+ ((lambda (g1806 g1805)
+ (g1787
+ ((letrec ((g1808
+ (lambda (g1810
+ g1809)
+ (if (null?
+ g1810)
+ g1809
+ (g1808
+ (cdr g1810)
+ (cons (car g1810)
+ g1809))))))
+ g1808)
+ (cdr g1805)
+ (car g1805))
+ (g437 (cons g1801 g1802)
+ g1789
+ (g248 g1806
+ g1805
+ g1788)
+ (g368 g1804
+ g1806
+ g1786))))
+ (g299 g1804)
+ (map g451 g1804))))
+ (g452 g1803)))
+ g1800)
+ ((lambda (g1811) (syntax-error g1789))
+ g1790)))
+ ($syntax-dispatch g1790 '(any any . each-any)))))
+ ($syntax-dispatch g1790 '(each-any any . each-any))))
+ g1785)))
+ (g443
+ (lambda (g872 g869 g871 g870)
+ ((lambda (g873)
+ ((lambda (g874)
+ (if (if g874
+ (apply
+ (lambda (g877 g875 g876) (g256 g875))
+ g874)
+ '#f)
+ (apply
+ (lambda (g880 g878 g879) (g870 g878 g879 g869))
+ g874)
+ ((lambda (g881)
+ (syntax-error (g394 g872 g869 g871)))
+ g873)))
+ ($syntax-dispatch g873 '(any any any))))
+ g872)))
+ (g442
+ (lambda (g1758 g1755 g1757 g1756)
+ ((lambda (g1759)
+ ((lambda (g1760)
+ (if (if g1760
+ (apply
+ (lambda (g1763 g1761 g1762) (g256 g1761))
+ g1760)
+ '#f)
+ (apply
+ (lambda (g1766 g1764 g1765)
+ (g1756 g1764 g1765 g1755))
+ g1760)
+ ((lambda (g1767)
+ (if (if g1767
+ (apply
+ (lambda (g1772
+ g1768
+ g1771
+ g1769
+ g1770)
+ (if (g256 g1768)
+ (g389 (g452 g1771))
+ '#f))
+ g1767)
+ '#f)
+ (apply
+ (lambda (g1777 g1773 g1776 g1774 g1775)
+ (g1756
+ (g393 g1773 g1755)
+ (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ name args e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e w s k)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (g393 (cons g1776
+ (cons g1774 g1775))
+ g1755))
+ '(())))
+ g1767)
+ ((lambda (g1779)
+ (if (if g1779
+ (apply
+ (lambda (g1781 g1780)
+ (g256 g1780))
+ g1779)
+ '#f)
+ (apply
+ (lambda (g1783 g1782)
+ (g1756
+ (g393 g1782 g1755)
+ '(#(syntax-object
+ void
+ ((top)
+ #(ribcage
+ #(_ name)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e w s k)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ '(())))
+ g1779)
+ ((lambda (g1784)
+ (syntax-error
+ (g394 g1758 g1755 g1757)))
+ g1759)))
+ ($syntax-dispatch g1759 '(any any)))))
+ ($syntax-dispatch
+ g1759
+ '(any (any . any) any . each-any)))))
+ ($syntax-dispatch g1759 '(any any any))))
+ g1758)))
+ (g441
+ (lambda (g885 g882 g884 g883)
+ ((lambda (g886)
+ ((lambda (g887)
+ (if (if g887
+ (apply (lambda (g889 g888) (g256 g888)) g887)
+ '#f)
+ (apply
+ (lambda (g891 g890) (g883 (g393 g890 g882)))
+ g887)
+ ((lambda (g892)
+ (syntax-error (g394 g885 g882 g884)))
+ g886)))
+ ($syntax-dispatch g886 '(any any))))
+ g885)))
+ (g440
+ (lambda (g1723 g1719 g1722 g1720 g1721)
+ (letrec ((g1725
+ (lambda (g1753 g1751 g1752)
+ (g1721
+ g1753
+ (g1724 g1751)
+ (map (lambda (g1754) (g393 g1754 g1720))
+ g1752))))
+ (g1724
+ (lambda (g1745)
+ (if (null? g1745)
+ '()
+ (cons ((lambda (g1746)
+ ((lambda (g1747)
+ (if g1747
+ (apply
+ (lambda (g1748)
+ (g1724 g1748))
+ g1747)
+ ((lambda (g1750)
+ (if (g256 g1750)
+ (g393 g1750 g1720)
+ (syntax-error
+ (g394 g1723
+ g1719
+ g1722)
+ '"invalid exports list in")))
+ g1746)))
+ ($syntax-dispatch
+ g1746
+ 'each-any)))
+ (car g1745))
+ (g1724 (cdr g1745)))))))
+ ((lambda (g1726)
+ ((lambda (g1727)
+ (if g1727
+ (apply
+ (lambda (g1730 g1728 g1729)
+ (g1725 '#f g1728 g1729))
+ g1727)
+ ((lambda (g1733)
+ (if (if g1733
+ (apply
+ (lambda (g1737 g1734 g1736 g1735)
+ (g256 g1734))
+ g1733)
+ '#f)
+ (apply
+ (lambda (g1741 g1738 g1740 g1739)
+ (g1725
+ (g393 g1738 g1719)
+ g1740
+ g1739))
+ g1733)
+ ((lambda (g1744)
+ (syntax-error
+ (g394 g1723 g1719 g1722)))
+ g1726)))
+ ($syntax-dispatch
+ g1726
+ '(any any each-any . each-any)))))
+ ($syntax-dispatch g1726 '(any each-any . each-any))))
+ g1723))))
+ (g439
+ (lambda (g894 g893)
+ ((lambda (g895)
+ (if g895
+ (g366 g893 g895)
+ (g429 (lambda (g896)
+ ((lambda (g897)
+ (begin (if (not g897)
+ (syntax-error
+ g896
+ '"exported identifier not visible")
+ (void))
+ (g363 g893 g896 g897)))
+ (g376 g896 '(()))))
+ (g404 g894))))
+ (g405 g894))))
+ (g438
+ (lambda (g1652 g1648 g1651 g1649 g1650)
+ (letrec ((g1653
+ (lambda (g1718 g1714 g1717 g1715 g1716)
+ (begin (g426 g1648 g1714)
+ (g1650 g1718 g1714 g1717 g1715 g1716)))))
+ ((letrec ((g1654
+ (lambda (g1659 g1655 g1658 g1656 g1657)
+ (if (null? g1659)
+ (g1653 g1659 g1655 g1658 g1656 g1657)
+ ((lambda (g1661 g1660)
+ (call-with-values
+ (lambda ()
+ (g398 g1661
+ g1660
+ '(())
+ '#f
+ g1652))
+ (lambda (g1666
+ g1662
+ g1665
+ g1663
+ g1664)
+ ((lambda (g1667)
+ (if (memv g1667 '(define-form))
+ (g442 g1665
+ g1663
+ g1664
+ (lambda (g1670
+ g1668
+ g1669)
+ ((lambda (g1672
+ g1671)
+ ((lambda (g1673)
+ (begin (g363 g1652
+ g1672
+ g1671)
+ (g424 g1649
+ g1671
+ (g231 'lexical
+ g1673))
+ (g1654
+ (cdr g1659)
+ (cons g1672
+ g1655)
+ (cons g1673
+ g1658)
+ (cons (cons g1660
+ (g393 g1668
+ g1669))
+ g1656)
+ g1657)))
+ (g451 g1672)))
+ (g393 g1670 g1669)
+ (g297))))
+ (if (memv g1667
+ '(define-syntax-form))
+ (g443 g1665
+ g1663
+ g1664
+ (lambda (g1676
+ g1674
+ g1675)
+ ((lambda (g1679
+ g1677
+ g1678)
+ (begin (g363 g1652
+ g1679
+ g1677)
+ (g424 g1649
+ g1677
+ (g231 'deferred
+ g1678))
+ (g1654
+ (cdr g1659)
+ (cons g1679
+ g1655)
+ g1658
+ g1656
+ g1657)))
+ (g393 g1676
+ g1675)
+ (g297)
+ (g432 g1674
+ (g249 g1660)
+ g1675))))
+ (if (memv g1667
+ '(module-form))
+ ((lambda (g1680)
+ ((lambda (g1681)
+ ((lambda ()
+ (g440 g1665
+ g1663
+ g1664
+ g1681
+ (lambda (g1684
+ g1682
+ g1683)
+ (g438 g1680
+ (g394 g1665
+ g1663
+ g1664)
+ (map (lambda (g1695)
+ (cons g1660
+ g1695))
+ g1683)
+ g1649
+ (lambda (g1689
+ g1685
+ g1688
+ g1686
+ g1687)
+ (begin (g425 g1648
+ (g401 g1682)
+ g1685)
+ ((lambda (g1693
+ g1690
+ g1692
+ g1691)
+ (if g1684
+ ((lambda (g1694)
+ (begin (g363 g1652
+ g1684
+ g1694)
+ (g424 g1649
+ g1694
+ (g231 'module
+ g1693))
+ (g1654
+ (cdr g1659)
+ (cons g1684
+ g1655)
+ g1690
+ g1692
+ g1691)))
+ (g297))
+ ((lambda ()
+ (begin (g439 g1693
+ g1652)
+ (g1654
+ (cdr g1659)
+ (cons g1693
+ g1655)
+ g1690
+ g1692
+ g1691))))))
+ (g408 g1682)
+ (append
+ g1688
+ g1658)
+ (append
+ g1686
+ g1656)
+ (append
+ g1657
+ g1687
+ g1689))))))))))
+ (g263 (g264 g1663)
+ (cons g1680
+ (g265 g1663)))))
+ (g304 '()
+ '()
+ '()))
+ (if (memv g1667
+ '(import-form))
+ (g441 g1665
+ g1663
+ g1664
+ (lambda (g1696)
+ ((lambda (g1697)
+ ((lambda (g1698)
+ ((lambda (g1699)
+ (if (memv g1699
+ '(module))
+ ((lambda (g1700)
+ (begin (if g1662
+ (g364 g1652
+ g1662)
+ (void))
+ (g439 g1700
+ g1652)
+ (g1654
+ (cdr g1659)
+ (cons g1700
+ g1655)
+ g1658
+ g1656
+ g1657)))
+ (cdr g1698))
+ (if (memv g1699
+ '(displaced-lexical))
+ (g250 g1696)
+ (syntax-error
+ g1696
+ '"import from unknown module"))))
+ (car g1698)))
+ (g253 g1697
+ g1649)))
+ (g377 g1696
+ '(())))))
+ (if (memv g1667
+ '(begin-form))
+ ((lambda (g1701)
+ ((lambda (g1702)
+ (if g1702
+ (apply
+ (lambda (g1704
+ g1703)
+ (g1654
+ ((letrec ((g1705
+ (lambda (g1706)
+ (if (null?
+ g1706)
+ (cdr g1659)
+ (cons (cons g1660
+ (g393 (car g1706)
+ g1663))
+ (g1705
+ (cdr g1706)))))))
+ g1705)
+ g1703)
+ g1655
+ g1658
+ g1656
+ g1657))
+ g1702)
+ (syntax-error
+ g1701)))
+ ($syntax-dispatch
+ g1701
+ '(any .
+ each-any))))
+ g1665)
+ (if (memv g1667
+ '(local-syntax-form))
+ (g445 g1662
+ g1665
+ g1660
+ g1663
+ g1664
+ (lambda (g1711
+ g1708
+ g1710
+ g1709)
+ (g1654
+ ((letrec ((g1712
+ (lambda (g1713)
+ (if (null?
+ g1713)
+ (cdr g1659)
+ (cons (cons g1708
+ (g393 (car g1713)
+ g1710))
+ (g1712
+ (cdr g1713)))))))
+ g1712)
+ g1711)
+ g1655
+ g1658
+ g1656
+ g1657)))
+ (g1653
+ (cons (cons g1660
+ (g394 g1665
+ g1663
+ g1664))
+ (cdr g1659))
+ g1655
+ g1658
+ g1656
+ g1657))))))))
+ g1666))))
+ (cdar g1659)
+ (caar g1659))))))
+ g1654)
+ g1651
+ '()
+ '()
+ '()
+ '()))))
+ (g437
+ (lambda (g901 g898 g900 g899)
+ ((lambda (g902)
+ ((lambda (g903)
+ ((lambda (g904)
+ ((lambda (g905)
+ ((lambda ()
+ (g438 g903
+ g898
+ g905
+ g902
+ (lambda (g910 g906 g909 g907 g908)
+ (begin (if (null? g910)
+ (syntax-error
+ g898
+ '"no expressions in body")
+ (void))
+ (g191 '#f
+ g909
+ (map (lambda (g912)
+ (g432 (cdr g912)
+ (car g912)
+ '(())))
+ g907)
+ (g190 '#f
+ (map (lambda (g911)
+ (g432 (cdr g911)
+ (car g911)
+ '(())))
+ (append
+ g908
+ g910))))))))))
+ (map (lambda (g913) (cons g902 (g393 g913 g904)))
+ g901)))
+ (g263 (g264 g899) (cons g903 (g265 g899)))))
+ (g304 '() '() '())))
+ (cons '("placeholder" placeholder) g900))))
+ (g436
+ (lambda (g1635 g1630 g1634 g1631 g1633 g1632)
+ (letrec ((g1636
+ (lambda (g1640 g1639)
+ (if (pair? g1640)
+ (cons (g1636 (car g1640) g1639)
+ (g1636 (cdr g1640) g1639))
+ (if (g204 g1640)
+ ((lambda (g1641)
+ ((lambda (g1643 g1642)
+ (g203 (g205 g1640)
+ (if (if (pair? g1643)
+ (eq? (car g1643)
+ '#f)
+ '#f)
+ (g263 (cdr g1643)
+ (if g1632
+ (cons g1632
+ (cdr g1642))
+ (cdr g1642)))
+ (g263 (cons g1639 g1643)
+ (if g1632
+ (cons g1632
+ (cons 'shift
+ g1642))
+ (cons 'shift
+ g1642))))))
+ (g264 g1641)
+ (g265 g1641)))
+ (g206 g1640))
+ (if (vector? g1640)
+ ((lambda (g1644)
+ ((lambda (g1645)
+ ((lambda ()
+ ((letrec ((g1646
+ (lambda (g1647)
+ (if (= g1647
+ g1644)
+ g1645
+ (begin (vector-set!
+ g1645
+ g1647
+ (g1636
+ (vector-ref
+ g1640
+ g1647)
+ g1639))
+ (g1646
+ (+ g1647
+ '1)))))))
+ g1646)
+ '0))))
+ (make-vector g1644)))
+ (vector-length g1640))
+ (if (symbol? g1640)
+ (syntax-error
+ (g394 g1630 g1631 g1633)
+ '"encountered raw symbol "
+ (format '"~s" g1640)
+ '" in output of macro")
+ g1640)))))))
+ (g1636
+ ((lambda (g1637)
+ (if (procedure? g1637)
+ (g1637
+ (lambda (g1638)
+ (begin (if (not (identifier? g1638))
+ (syntax-error
+ g1638
+ '"environment argument is not an identifier")
+ (void))
+ (g253 (g377 g1638 '(())) g1634))))
+ g1637))
+ (g1635 (g394 g1630 (g349 g1631) g1633)))
+ (string '#\m)))))
+ (g435
+ (lambda (g918 g914 g917 g915 g916)
+ ((lambda (g919)
+ ((lambda (g920)
+ (if (if g920
+ (apply
+ (lambda (g923 g921 g922) (g256 g921))
+ g920)
+ '#f)
+ (apply
+ (lambda (g926 g924 g925)
+ ((lambda (g927)
+ ((lambda (g928)
+ ((lambda (g929)
+ (if (memv g929 '(macro!))
+ ((lambda (g931 g930)
+ (g398 (g436 (g233 g928)
+ (list '#(syntax-object
+ set!
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(id
+ val)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(t)
+ #(("m" top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(b)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(n)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ id
+ val)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g931
+ g930)
+ g914
+ '(())
+ g915
+ g916)
+ g914
+ '(())
+ g915
+ g916))
+ (g393 g924 g917)
+ (g393 g925 g917))
+ (values
+ 'core
+ (lambda (g935 g932 g934 g933)
+ ((lambda (g937 g936)
+ ((lambda (g938)
+ ((lambda (g939)
+ (if (memv g939
+ '(lexical))
+ (list 'set!
+ (g233 g938)
+ g937)
+ (if (memv g939
+ '(global))
+ (list 'set!
+ (g233 g938)
+ g937)
+ (if (memv g939
+ '(displaced-lexical))
+ (syntax-error
+ (g393 g924
+ g934)
+ '"identifier out of context")
+ (syntax-error
+ (g394 g935
+ g934
+ g933))))))
+ (g232 g938)))
+ (g253 g936 g932)))
+ (g432 g925 g932 g934)
+ (g377 g924 g934)))
+ g918
+ g917
+ g915)))
+ (g232 g928)))
+ (g253 g927 g914)))
+ (g377 g924 g917)))
+ g920)
+ ((lambda (g940)
+ (syntax-error (g394 g918 g917 g915)))
+ g919)))
+ ($syntax-dispatch g919 '(any any any))))
+ g918)))
+ (g434
+ (lambda (g1622 g1618 g1621 g1619 g1620)
+ ((lambda (g1623)
+ ((lambda (g1624)
+ (if g1624
+ (apply
+ (lambda (g1626 g1625)
+ (cons g1622
+ (map (lambda (g1628)
+ (g432 g1628 g1621 g1619))
+ g1625)))
+ g1624)
+ ((lambda (g1629)
+ (syntax-error (g394 g1618 g1619 g1620)))
+ g1623)))
+ ($syntax-dispatch g1623 '(any . each-any))))
+ g1618)))
+ (g433
+ (lambda (g946 g941 g945 g942 g944 g943)
+ ((lambda (g947)
+ (if (memv g947 '(lexical))
+ g941
+ (if (memv g947 '(core))
+ (g941 g945 g942 g944 g943)
+ (if (memv g947 '(lexical-call))
+ (g434 g941 g945 g942 g944 g943)
+ (if (memv g947 '(constant))
+ (list 'quote
+ (g450 (g394 g945 g944 g943) '(())))
+ (if (memv g947 '(global))
+ g941
+ (if (memv g947 '(call))
+ (g434 (g432 (car g945) g942 g944)
+ g945
+ g942
+ g944
+ g943)
+ (if (memv g947 '(begin-form))
+ ((lambda (g948)
+ ((lambda (g949)
+ (if g949
+ (apply
+ (lambda (g952
+ g950
+ g951)
+ (g395 (cons g950
+ g951)
+ g942
+ g944
+ g943))
+ g949)
+ (syntax-error
+ g948)))
+ ($syntax-dispatch
+ g948
+ '(any any
+ .
+ each-any))))
+ g945)
+ (if (memv g947
+ '(local-syntax-form))
+ (g445 g941
+ g945
+ g942
+ g944
+ g943
+ g395)
+ (if (memv g947
+ '(eval-when-form))
+ ((lambda (g954)
+ ((lambda (g955)
+ (if g955
+ (apply
+ (lambda (g959
+ g956
+ g958
+ g957)
+ ((lambda (g960)
+ (if (memq 'eval
+ g960)
+ (g395 (cons g958
+ g957)
+ g942
+ g944
+ g943)
+ (g446)))
+ (g397 g945
+ g956
+ g944)))
+ g955)
+ (syntax-error
+ g954)))
+ ($syntax-dispatch
+ g954
+ '(any each-any
+ any
+ .
+ each-any))))
+ g945)
+ (if (memv g947
+ '(define-form
+ define-syntax-form
+ module-form
+ import-form))
+ (syntax-error
+ (g394 g945
+ g944
+ g943)
+ '"invalid context for definition")
+ (if (memv g947
+ '(syntax))
+ (syntax-error
+ (g394 g945
+ g944
+ g943)
+ '"reference to pattern variable outside syntax form")
+ (if (memv g947
+ '(displaced-lexical))
+ (g250 (g394 g945
+ g944
+ g943))
+ (syntax-error
+ (g394 g945
+ g944
+ g943)))))))))))))))
+ g946)))
+ (g432
+ (lambda (g1612 g1610 g1611)
+ (call-with-values
+ (lambda () (g398 g1612 g1610 g1611 '#f '#f))
+ (lambda (g1617 g1613 g1616 g1614 g1615)
+ (g433 g1617 g1613 g1616 g1610 g1614 g1615)))))
+ (g431
+ (lambda (g965 g963 g964)
+ ((lambda (g966)
+ (if (memv g966 '(c))
+ (if (memq 'compile g963)
+ ((lambda (g967)
+ (begin (g91 g967)
+ (if (memq 'load g963) g967 (g446))))
+ (g964))
+ (if (memq 'load g963) (g964) (g446)))
+ (if (memv g966 '(c&e))
+ ((lambda (g968) (begin (g91 g968) g968)) (g964))
+ (begin (if (memq 'eval g963) (g91 (g964)) (void))
+ (g446)))))
+ g965)))
+ (g430
+ (lambda (g1609 g1608)
+ (list '$sc-put-cte
+ (list 'quote g1609)
+ (list 'quote (g231 'do-import g1608)))))
+ (g429
+ (lambda (g970 g969)
+ ((lambda (g971)
+ ((letrec ((g972
+ (lambda (g973)
+ (if (not (= g973 g971))
+ (begin (g970 (vector-ref g969 g973))
+ (g972 (+ g973 '1)))
+ (void)))))
+ g972)
+ '0))
+ (vector-length g969))))
+ (g428
+ (lambda (g1604 g1603)
+ ((letrec ((g1605
+ (lambda (g1607 g1606)
+ (if (< g1607 '0)
+ g1606
+ (g1605
+ (- g1607 '1)
+ (cons (g1604 (vector-ref g1603 g1607))
+ g1606))))))
+ g1605)
+ (- (vector-length g1603) '1)
+ '())))
+ (g427
+ (lambda (g982 g974 g981 g975 g980 g976 g979 g977 g978)
+ (letrec ((g985
+ (lambda (g1050 g1049)
+ ((lambda (g1051)
+ (map (lambda (g1052)
+ ((lambda (g1053)
+ (if (not (g392 g1053 g1051))
+ g1052
+ (g410 (g412 g1052)
+ g1053
+ (g414 g1052)
+ (append
+ (g984 g1053)
+ (g415 g1052))
+ (g416 g1052))))
+ (g413 g1052)))
+ g1050))
+ (map (lambda (g1054)
+ (if (pair? g1054) (car g1054) g1054))
+ g1049))))
+ (g984
+ (lambda (g1043)
+ ((letrec ((g1044
+ (lambda (g1045)
+ (if (null? g1045)
+ '()
+ (if (if (pair? (car g1045))
+ (g388 g1043
+ (caar g1045))
+ '#f)
+ (g401 (cdar g1045))
+ (g1044 (cdr g1045)))))))
+ g1044)
+ g980)))
+ (g983
+ (lambda (g1048 g1046 g1047)
+ (begin (g426 g974 g1046)
+ (g425 g974 g976 g1046)
+ (g978 g1048 g1047)))))
+ ((letrec ((g986
+ (lambda (g990 g987 g989 g988)
+ (if (null? g990)
+ (g983 g989 g987 g988)
+ ((lambda (g992 g991)
+ (call-with-values
+ (lambda ()
+ (g398 g992 g991 '(()) '#f g982))
+ (lambda (g997 g993 g996 g994 g995)
+ ((lambda (g998)
+ (if (memv g998 '(define-form))
+ (g442 g996
+ g994
+ g995
+ (lambda (g1001
+ g999
+ g1000)
+ ((lambda (g1002)
+ ((lambda (g1003)
+ ((lambda (g1004)
+ ((lambda ()
+ (begin (g363 g982
+ g1002
+ g1003)
+ (g986 (cdr g990)
+ (cons g1002
+ g987)
+ (cons (g410 g997
+ g1002
+ g1003
+ g1004
+ (cons g991
+ (g393 g999
+ g1000)))
+ g989)
+ g988)))))
+ (g984 g1002)))
+ (g300)))
+ (g393 g1001
+ g1000))))
+ (if (memv g998
+ '(define-syntax-form))
+ (g443 g996
+ g994
+ g995
+ (lambda (g1007
+ g1005
+ g1006)
+ ((lambda (g1008)
+ ((lambda (g1009)
+ ((lambda (g1010)
+ ((lambda (g1011)
+ ((lambda ()
+ (begin (g424 g975
+ (g302 g1009)
+ (cons 'deferred
+ g1011))
+ (g363 g982
+ g1008
+ g1009)
+ (g986 (cdr g990)
+ (cons g1008
+ g987)
+ (cons (g410 g997
+ g1008
+ g1009
+ g1010
+ g1011)
+ g989)
+ g988)))))
+ (g432 g1005
+ (g249 g991)
+ g1006)))
+ (g984 g1008)))
+ (g300)))
+ (g393 g1007
+ g1006))))
+ (if (memv g998
+ '(module-form))
+ ((lambda (g1012)
+ ((lambda (g1013)
+ ((lambda ()
+ (g440 g996
+ g994
+ g995
+ g1013
+ (lambda (g1016
+ g1014
+ g1015)
+ (g427 g1012
+ (g394 g996
+ g994
+ g995)
+ (map (lambda (g1024)
+ (cons g991
+ g1024))
+ g1015)
+ g975
+ g1014
+ (g401 g1014)
+ g979
+ g977
+ (lambda (g1018
+ g1017)
+ ((lambda (g1019)
+ ((lambda (g1020)
+ ((lambda (g1021)
+ ((lambda ()
+ (if g1016
+ ((lambda (g1023
+ g1022)
+ (begin (g424 g975
+ (g302 g1023)
+ (g231 'module
+ g1019))
+ (g363 g982
+ g1016
+ g1023)
+ (g986 (cdr g990)
+ (cons g1016
+ g987)
+ (cons (g410 g997
+ g1016
+ g1023
+ g1022
+ g1014)
+ g1020)
+ g1021)))
+ (g300)
+ (g984 g1016))
+ ((lambda ()
+ (begin (g439 g1019
+ g982)
+ (g986 (cdr g990)
+ (cons g1019
+ g987)
+ g1020
+ g1021))))))))
+ (append
+ g988
+ g1017)))
+ (append
+ (if g1016
+ g1018
+ (g985 g1018
+ g1014))
+ g989)))
+ (g408 g1014)))))))))
+ (g263 (g264 g994)
+ (cons g1012
+ (g265 g994)))))
+ (g304 '()
+ '()
+ '()))
+ (if (memv g998
+ '(import-form))
+ (g441 g996
+ g994
+ g995
+ (lambda (g1025)
+ ((lambda (g1026)
+ ((lambda (g1027)
+ ((lambda (g1028)
+ (if (memv g1028
+ '(module))
+ ((lambda (g1029)
+ (begin (if g993
+ (g364 g982
+ g993)
+ (void))
+ (g439 g1029
+ g982)
+ (g986 (cdr g990)
+ (cons g1029
+ g987)
+ (g985 g989
+ (vector->list
+ (g404 g1029)))
+ g988)))
+ (g233 g1027))
+ (if (memv g1028
+ '(displaced-lexical))
+ (g250 g1025)
+ (syntax-error
+ g1025
+ '"import from unknown module"))))
+ (g232 g1027)))
+ (g253 g1026
+ g975)))
+ (g377 g1025
+ '(())))))
+ (if (memv g998
+ '(begin-form))
+ ((lambda (g1030)
+ ((lambda (g1031)
+ (if g1031
+ (apply
+ (lambda (g1033
+ g1032)
+ (g986 ((letrec ((g1034
+ (lambda (g1035)
+ (if (null?
+ g1035)
+ (cdr g990)
+ (cons (cons g991
+ (g393 (car g1035)
+ g994))
+ (g1034
+ (cdr g1035)))))))
+ g1034)
+ g1032)
+ g987
+ g989
+ g988))
+ g1031)
+ (syntax-error
+ g1030)))
+ ($syntax-dispatch
+ g1030
+ '(any .
+ each-any))))
+ g996)
+ (if (memv g998
+ '(local-syntax-form))
+ (g445 g993
+ g996
+ g991
+ g994
+ g995
+ (lambda (g1040
+ g1037
+ g1039
+ g1038)
+ (g986 ((letrec ((g1041
+ (lambda (g1042)
+ (if (null?
+ g1042)
+ (cdr g990)
+ (cons (cons g1037
+ (g393 (car g1042)
+ g1039))
+ (g1041
+ (cdr g1042)))))))
+ g1041)
+ g1040)
+ g987
+ g989
+ g988)))
+ (g983 g989
+ g987
+ (append
+ g988
+ (cons (cons g991
+ (g394 g996
+ g994
+ g995))
+ (cdr g990)))))))))))
+ g997))))
+ (cdar g990)
+ (caar g990))))))
+ g986)
+ g981
+ '()
+ '()
+ '()))))
+ (g426
+ (lambda (g1560 g1559)
+ (letrec ((g1564
+ (lambda (g1597 g1595 g1596)
+ ((lambda (g1598)
+ (if g1598
+ (if (g367 ((lambda (g1599)
+ ((lambda (g1600)
+ (if (g90 g1600)
+ (annotation-expression
+ g1600)
+ g1600))
+ (if (g204 g1599)
+ (g205 g1599)
+ g1599)))
+ g1597)
+ g1598
+ (if (symbol? g1597)
+ (g264 '((top)))
+ (g264 (g206 g1597))))
+ (cons g1597 g1596)
+ g1596)
+ (g1562
+ (g404 g1595)
+ (lambda (g1602 g1601)
+ (if (g1561 g1602 g1597)
+ (cons g1602 g1601)
+ g1601))
+ g1596)))
+ (g405 g1595))))
+ (g1563
+ (lambda (g1575 g1573 g1574)
+ (if (g403 g1575)
+ (if (g403 g1573)
+ (call-with-values
+ (lambda ()
+ ((lambda (g1581 g1580)
+ (if (fx> (vector-length g1581)
+ (vector-length g1580))
+ (values g1575 g1580)
+ (values g1573 g1581)))
+ (g404 g1575)
+ (g404 g1573)))
+ (lambda (g1577 g1576)
+ (g1562
+ g1576
+ (lambda (g1579 g1578)
+ (g1564 g1579 g1577 g1578))
+ g1574)))
+ (g1564 g1573 g1575 g1574))
+ (if (g403 g1573)
+ (g1564 g1575 g1573 g1574)
+ (if (g1561 g1575 g1573)
+ (cons g1575 g1574)
+ g1574)))))
+ (g1562
+ (lambda (g1590 g1588 g1589)
+ ((lambda (g1591)
+ ((letrec ((g1592
+ (lambda (g1594 g1593)
+ (if (= g1594 g1591)
+ g1593
+ (g1592
+ (+ g1594 '1)
+ (g1588
+ (vector-ref g1590 g1594)
+ g1593))))))
+ g1592)
+ '0
+ g1589))
+ (vector-length g1590))))
+ (g1561
+ (lambda (g1583 g1582)
+ (if (symbol? g1583)
+ (if (symbol? g1582)
+ (eq? g1583 g1582)
+ (if (eq? g1583
+ ((lambda (g1584)
+ ((lambda (g1585)
+ (if (g90 g1585)
+ (annotation-expression
+ g1585)
+ g1585))
+ (if (g204 g1584)
+ (g205 g1584)
+ g1584)))
+ g1582))
+ (g373 (g264 (g206 g1582))
+ (g264 '((top))))
+ '#f))
+ (if (symbol? g1582)
+ (if (eq? g1582
+ ((lambda (g1586)
+ ((lambda (g1587)
+ (if (g90 g1587)
+ (annotation-expression
+ g1587)
+ g1587))
+ (if (g204 g1586)
+ (g205 g1586)
+ g1586)))
+ g1583))
+ (g373 (g264 (g206 g1583))
+ (g264 '((top))))
+ '#f)
+ (g388 g1583 g1582))))))
+ (if (not (null? g1559))
+ ((letrec ((g1565
+ (lambda (g1568 g1566 g1567)
+ (if (null? g1566)
+ (if (not (null? g1567))
+ ((lambda (g1569)
+ (syntax-error
+ g1560
+ '"duplicate definition for "
+ (symbol->string (car g1569))
+ '" in"))
+ (syntax-object->datum g1567))
+ (void))
+ ((letrec ((g1570
+ (lambda (g1572 g1571)
+ (if (null? g1572)
+ (g1565
+ (car g1566)
+ (cdr g1566)
+ g1571)
+ (g1570
+ (cdr g1572)
+ (g1563
+ g1568
+ (car g1572)
+ g1571))))))
+ g1570)
+ g1566
+ g1567)))))
+ g1565)
+ (car g1559)
+ (cdr g1559)
+ '())
+ (void)))))
+ (g425
+ (lambda (g1057 g1055 g1056)
+ (letrec ((g1058
+ (lambda (g1065 g1064)
+ (ormap
+ (lambda (g1066)
+ (if (g403 g1066)
+ ((lambda (g1067)
+ (if g1067
+ (g367 ((lambda (g1068)
+ ((lambda (g1069)
+ (if (g90 g1069)
+ (annotation-expression
+ g1069)
+ g1069))
+ (if (g204 g1068)
+ (g205 g1068)
+ g1068)))
+ g1065)
+ g1067
+ (g264 (g206 g1065)))
+ ((lambda (g1070)
+ ((letrec ((g1071
+ (lambda (g1072)
+ (if (fx>= g1072
+ '0)
+ ((lambda (g1073)
+ (if g1073
+ g1073
+ (g1071
+ (- g1072
+ '1))))
+ (g388 g1065
+ (vector-ref
+ g1070
+ g1072)))
+ '#f))))
+ g1071)
+ (- (vector-length g1070)
+ '1)))
+ (g404 g1066))))
+ (g405 g1066))
+ (g388 g1065 g1066)))
+ g1064))))
+ ((letrec ((g1059
+ (lambda (g1061 g1060)
+ (if (null? g1061)
+ (if (not (null? g1060))
+ (syntax-error
+ g1060
+ '"missing definition for export(s)")
+ (void))
+ ((lambda (g1063 g1062)
+ (if (g1058 g1063 g1056)
+ (g1059 g1062 g1060)
+ (g1059 g1062 (cons g1063 g1060))))
+ (car g1061)
+ (cdr g1061))))))
+ g1059)
+ g1055
+ '()))))
+ (g424
+ (lambda (g1558 g1556 g1557)
+ (set-cdr! g1558 (g246 g1556 g1557 (cdr g1558)))))
+ (g423
+ (lambda (g1075 g1074)
+ (if (null? g1075)
+ '()
+ (if (g392 (car g1075) g1074)
+ (g423 (cdr g1075) g1074)
+ (cons (car g1075) (g423 (cdr g1075) g1074))))))
+ (g422
+ (lambda (g1491
+ g1482
+ g1490
+ g1483
+ g1489
+ g1484
+ g1488
+ g1485
+ g1487
+ g1486)
+ ((lambda (g1492)
+ (g427 g1490
+ (g394 g1491 g1483 g1489)
+ (map (lambda (g1555) (cons g1482 g1555)) g1486)
+ g1482
+ g1487
+ g1492
+ g1484
+ g1488
+ (lambda (g1494 g1493)
+ ((letrec ((g1495
+ (lambda (g1500
+ g1496
+ g1499
+ g1497
+ g1498)
+ (if (null? g1500)
+ ((letrec ((g1501
+ (lambda (g1504
+ g1502
+ g1503)
+ (if (null? g1504)
+ ((lambda (g1507
+ g1505
+ g1506)
+ (begin (for-each
+ (lambda (g1523)
+ (apply
+ (lambda (g1527
+ g1524
+ g1526
+ g1525)
+ (if g1524
+ (g303 g1524
+ g1526)
+ (void)))
+ g1523))
+ g1498)
+ (g190 '#f
+ (list (g431 g1484
+ g1488
+ (lambda ()
+ (if (null?
+ g1498)
+ (g446)
+ (g190 '#f
+ (map (lambda (g1518)
+ (apply
+ (lambda (g1522
+ g1519
+ g1521
+ g1520)
+ (list '$sc-put-cte
+ (list 'quote
+ g1521)
+ (if (eq? g1522
+ 'define-syntax-form)
+ g1520
+ (list 'quote
+ (g231 'module
+ (g409 g1520
+ g1521))))))
+ g1518))
+ g1498)))))
+ (g431 g1484
+ g1488
+ (lambda ()
+ ((lambda (g1508)
+ ((lambda (g1509)
+ ((lambda (g1510)
+ ((lambda ()
+ (if g1508
+ (list '$sc-put-cte
+ (list 'quote
+ (if (g373 (g264 (g206 g1485))
+ (g264 '((top))))
+ g1508
+ ((lambda (g1511)
+ (g203 g1508
+ (g263 g1511
+ (list (g304 (vector
+ g1508)
+ (vector
+ g1511)
+ (vector
+ (g101 g1508)))))))
+ (g264 (g206 g1485)))))
+ g1510)
+ ((lambda (g1512)
+ (g190 '#f
+ (list (list '$sc-put-cte
+ (list 'quote
+ g1512)
+ g1510)
+ (g430 g1512
+ g1509))))
+ (g101 'tmp))))))
+ (list 'quote
+ (g231 'module
+ (g409 g1487
+ g1509)))))
+ (g101 g1508)))
+ (if g1485
+ ((lambda (g1513)
+ ((lambda (g1514)
+ (if (g90 g1514)
+ (annotation-expression
+ g1514)
+ g1514))
+ (if (g204 g1513)
+ (g205 g1513)
+ g1513)))
+ g1485)
+ '#f))))
+ (g190 '#f
+ (map (lambda (g1517)
+ (list 'define
+ g1517
+ (g446)))
+ g1499))
+ (g191 '#f
+ g1502
+ g1505
+ (g190 '#f
+ (list (if (null?
+ g1499)
+ (g446)
+ (g190 '#f
+ (map (lambda (g1516
+ g1515)
+ (list 'set!
+ g1516
+ g1515))
+ g1499
+ g1507)))
+ (if (null?
+ g1506)
+ (g446)
+ (g190 '#f
+ g1506)))))
+ (g446)))))
+ (map (lambda (g1530)
+ (g432 (cdr g1530)
+ (car g1530)
+ '(())))
+ g1497)
+ (map (lambda (g1528)
+ (g432 (cdr g1528)
+ (car g1528)
+ '(())))
+ g1503)
+ (map (lambda (g1529)
+ (g432 (cdr g1529)
+ (car g1529)
+ '(())))
+ g1493))
+ ((lambda (g1531)
+ ((lambda (g1532)
+ (if (memv g1532
+ '(define-form))
+ ((lambda (g1533)
+ (begin (g424 g1482
+ (g302 (g414 g1531))
+ (g231 'lexical
+ g1533))
+ (g1501
+ (cdr g1504)
+ (cons g1533
+ g1502)
+ (cons (g416 g1531)
+ g1503))))
+ (g451 (g413 g1531)))
+ (if (memv g1532
+ '(define-syntax-form
+ module-form))
+ (g1501
+ (cdr g1504)
+ g1502
+ g1503)
+ (error 'sc-expand-internal
+ '"unexpected module binding type"))))
+ (g412 g1531)))
+ (car g1504))))))
+ g1501)
+ g1496
+ '()
+ '())
+ ((lambda (g1535 g1534)
+ (letrec ((g1536
+ (lambda (g1551
+ g1548
+ g1550
+ g1549)
+ ((letrec ((g1552
+ (lambda (g1554
+ g1553)
+ (if (null?
+ g1554)
+ (g1549)
+ (if (g388 (g413 (car g1554))
+ g1551)
+ (g1550
+ (car g1554)
+ (g370 (reverse
+ g1553)
+ (cdr g1554)))
+ (g1552
+ (cdr g1554)
+ (cons (car g1554)
+ g1553)))))))
+ g1552)
+ g1548
+ '()))))
+ (g1536
+ g1535
+ g1496
+ (lambda (g1538 g1537)
+ ((lambda (g1541
+ g1539
+ g1540)
+ ((lambda (g1543
+ g1542)
+ ((lambda (g1544)
+ (if (memv g1544
+ '(define-form))
+ (begin (g303 g1539
+ g1542)
+ (g1495
+ g1543
+ g1537
+ (cons g1542
+ g1499)
+ (cons (g416 g1538)
+ g1497)
+ g1498))
+ (if (memv g1544
+ '(define-syntax-form))
+ (g1495
+ g1543
+ g1537
+ g1499
+ g1497
+ (cons (list g1541
+ g1539
+ g1542
+ (g416 g1538))
+ g1498))
+ (if (memv g1544
+ '(module-form))
+ ((lambda (g1545)
+ (g1495
+ (append
+ (g401 g1545)
+ g1543)
+ g1537
+ g1499
+ g1497
+ (cons (list g1541
+ g1539
+ g1542
+ g1545)
+ g1498)))
+ (g416 g1538))
+ (error 'sc-expand-internal
+ '"unexpected module binding type")))))
+ g1541))
+ (append
+ g1540
+ g1534)
+ (g101 ((lambda (g1546)
+ ((lambda (g1547)
+ (if (g90 g1547)
+ (annotation-expression
+ g1547)
+ g1547))
+ (if (g204 g1546)
+ (g205 g1546)
+ g1546)))
+ g1535))))
+ (g412 g1538)
+ (g414 g1538)
+ (g415 g1538)))
+ (lambda ()
+ (g1495
+ g1534
+ g1496
+ g1499
+ g1497
+ g1498)))))
+ (car g1500)
+ (cdr g1500))))))
+ g1495)
+ g1492
+ g1494
+ '()
+ '()
+ '()))))
+ (g401 g1487))))
+ (g421 (lambda (g1077 g1076) (vector-set! g1077 '5 g1076)))
+ (g420 (lambda (g1481 g1480) (vector-set! g1481 '4 g1480)))
+ (g419 (lambda (g1079 g1078) (vector-set! g1079 '3 g1078)))
+ (g418 (lambda (g1479 g1478) (vector-set! g1479 '2 g1478)))
+ (g417 (lambda (g1081 g1080) (vector-set! g1081 '1 g1080)))
+ (g416 (lambda (g1477) (vector-ref g1477 '5)))
+ (g415 (lambda (g1082) (vector-ref g1082 '4)))
+ (g414 (lambda (g1476) (vector-ref g1476 '3)))
+ (g413 (lambda (g1083) (vector-ref g1083 '2)))
+ (g412 (lambda (g1475) (vector-ref g1475 '1)))
+ (g411
+ (lambda (g1084)
+ (if (vector? g1084)
+ (if (= (vector-length g1084) '6)
+ (eq? (vector-ref g1084 '0) 'module-binding)
+ '#f)
+ '#f)))
+ (g410
+ (lambda (g1474 g1470 g1473 g1471 g1472)
+ (vector 'module-binding g1474 g1470 g1473 g1471 g1472)))
+ (g409
+ (lambda (g1086 g1085)
+ (g402 (list->vector
+ (map (lambda (g1087)
+ (g369 (if (pair? g1087) (car g1087) g1087)))
+ g1086))
+ g1085)))
+ (g408
+ (lambda (g1468)
+ (g402 (list->vector
+ (map (lambda (g1469)
+ (if (pair? g1469) (car g1469) g1469))
+ g1468))
+ '#f)))
+ (g407 (lambda (g1089 g1088) (vector-set! g1089 '2 g1088)))
+ (g406 (lambda (g1467 g1466) (vector-set! g1467 '1 g1466)))
+ (g405 (lambda (g1090) (vector-ref g1090 '2)))
+ (g404 (lambda (g1465) (vector-ref g1465 '1)))
+ (g403
+ (lambda (g1091)
+ (if (vector? g1091)
+ (if (= (vector-length g1091) '3)
+ (eq? (vector-ref g1091 '0) 'interface)
+ '#f)
+ '#f)))
+ (g402
+ (lambda (g1464 g1463) (vector 'interface g1464 g1463)))
+ (g401
+ (lambda (g1092)
+ ((letrec ((g1093
+ (lambda (g1095 g1094)
+ (if (null? g1095)
+ g1094
+ (g1093
+ (cdr g1095)
+ (if (pair? (car g1095))
+ (g1093 (car g1095) g1094)
+ (cons (car g1095) g1094)))))))
+ g1093)
+ g1092
+ '())))
+ (g400
+ (lambda (g1390 g1385 g1389 g1386 g1388 g1387)
+ (call-with-values
+ (lambda () (g398 g1390 g1385 g1389 '#f g1387))
+ (lambda (g1401 g1397 g1400 g1398 g1399)
+ ((lambda (g1402)
+ (if (memv g1402 '(begin-form))
+ ((lambda (g1403)
+ ((lambda (g1404)
+ (if g1404
+ (apply (lambda (g1405) (g446)) g1404)
+ ((lambda (g1406)
+ (if g1406
+ (apply
+ (lambda (g1409 g1407 g1408)
+ (g396 (cons g1407 g1408)
+ g1385
+ g1398
+ g1399
+ g1386
+ g1388
+ g1387))
+ g1406)
+ (syntax-error g1403)))
+ ($syntax-dispatch
+ g1403
+ '(any any . each-any)))))
+ ($syntax-dispatch g1403 '(any))))
+ g1400)
+ (if (memv g1402 '(local-syntax-form))
+ (g445 g1397
+ g1400
+ g1385
+ g1398
+ g1399
+ (lambda (g1414 g1411 g1413 g1412)
+ (g396 g1414
+ g1411
+ g1413
+ g1412
+ g1386
+ g1388
+ g1387)))
+ (if (memv g1402 '(eval-when-form))
+ ((lambda (g1415)
+ ((lambda (g1416)
+ (if g1416
+ (apply
+ (lambda (g1420
+ g1417
+ g1419
+ g1418)
+ ((lambda (g1422 g1421)
+ (if (eq? g1386 'e)
+ (if (memq 'eval
+ g1422)
+ (g396 g1421
+ g1385
+ g1398
+ g1399
+ 'e
+ '(eval)
+ g1387)
+ (g446))
+ (if (memq 'load
+ g1422)
+ (if ((lambda (g1423)
+ (if g1423
+ g1423
+ (if (eq? g1386
+ 'c&e)
+ (memq 'eval
+ g1422)
+ '#f)))
+ (memq 'compile
+ g1422))
+ (g396 g1421
+ g1385
+ g1398
+ g1399
+ 'c&e
+ '(compile
+ load)
+ g1387)
+ (if (memq g1386
+ '(c c&e))
+ (g396 g1421
+ g1385
+ g1398
+ g1399
+ 'c
+ '(load)
+ g1387)
+ (g446)))
+ (if ((lambda (g1424)
+ (if g1424
+ g1424
+ (if (eq? g1386
+ 'c&e)
+ (memq 'eval
+ g1422)
+ '#f)))
+ (memq 'compile
+ g1422))
+ (begin (g91 (g396 g1421
+ g1385
+ g1398
+ g1399
+ 'e
+ '(eval)
+ g1387))
+ (g446))
+ (g446)))))
+ (g397 g1400 g1417 g1398)
+ (cons g1419 g1418)))
+ g1416)
+ (syntax-error g1415)))
+ ($syntax-dispatch
+ g1415
+ '(any each-any any . each-any))))
+ g1400)
+ (if (memv g1402 '(define-syntax-form))
+ (g443 g1400
+ g1398
+ g1399
+ (lambda (g1429 g1427 g1428)
+ ((lambda (g1430)
+ (begin ((lambda (g1435)
+ ((lambda (g1436)
+ ((lambda (g1437)
+ (if (memv g1437
+ '(displaced-lexical))
+ (g250 g1430)
+ (void)))
+ (g232 g1436)))
+ (g253 g1435
+ g1385)))
+ (g377 g1430
+ '(())))
+ (g431 g1386
+ g1388
+ (lambda ()
+ (list '$sc-put-cte
+ (list 'quote
+ ((lambda (g1431)
+ (if (g373 (g264 (g206 g1430))
+ (g264 '((top))))
+ g1431
+ ((lambda (g1432)
+ (g203 g1431
+ (g263 g1432
+ (list (g304 (vector
+ g1431)
+ (vector
+ g1432)
+ (vector
+ (g101 g1431)))))))
+ (g264 (g206 g1430)))))
+ ((lambda (g1433)
+ ((lambda (g1434)
+ (if (g90 g1434)
+ (annotation-expression
+ g1434)
+ g1434))
+ (if (g204 g1433)
+ (g205 g1433)
+ g1433)))
+ g1430)))
+ (g432 g1427
+ (g249 g1385)
+ g1428))))))
+ (g393 g1429 g1428))))
+ (if (memv g1402 '(define-form))
+ (g442 g1400
+ g1398
+ g1399
+ (lambda (g1440 g1438 g1439)
+ ((lambda (g1441)
+ (begin ((lambda (g1448)
+ ((lambda (g1449)
+ ((lambda (g1450)
+ (if (memv g1450
+ '(displaced-lexical))
+ (g250 g1441)
+ (void)))
+ (g232 g1449)))
+ (g253 g1448
+ g1385)))
+ (g377 g1441
+ '(())))
+ ((lambda (g1442)
+ ((lambda (g1443)
+ (g190 '#f
+ (list (g431 g1386
+ g1388
+ (lambda ()
+ (list '$sc-put-cte
+ (list 'quote
+ (if (eq? g1442
+ g1443)
+ g1442
+ ((lambda (g1445)
+ (g203 g1442
+ (g263 g1445
+ (list (g304 (vector
+ g1442)
+ (vector
+ g1445)
+ (vector
+ g1443))))))
+ (g264 (g206 g1441)))))
+ (list 'quote
+ (g231 'global
+ g1443)))))
+ ((lambda (g1444)
+ (begin (if (eq? g1386
+ 'c&e)
+ (g91 g1444)
+ (void))
+ g1444))
+ (list 'define
+ g1443
+ (g432 g1438
+ g1385
+ g1439))))))
+ (if (g373 (g264 (g206 g1441))
+ (g264 '((top))))
+ g1442
+ (g101 g1442))))
+ ((lambda (g1446)
+ ((lambda (g1447)
+ (if (g90 g1447)
+ (annotation-expression
+ g1447)
+ g1447))
+ (if (g204 g1446)
+ (g205 g1446)
+ g1446)))
+ g1441))))
+ (g393 g1440 g1439))))
+ (if (memv g1402 '(module-form))
+ ((lambda (g1452 g1451)
+ (g440 g1400
+ g1398
+ g1399
+ (g263 (g264 g1398)
+ (cons g1451
+ (g265 g1398)))
+ (lambda (g1455
+ g1453
+ g1454)
+ (if g1455
+ (begin ((lambda (g1456)
+ ((lambda (g1457)
+ ((lambda (g1458)
+ (if (memv g1458
+ '(displaced-lexical))
+ (g250 (g393 g1455
+ g1398))
+ (void)))
+ (g232 g1457)))
+ (g253 g1456
+ g1452)))
+ (g377 g1455
+ '(())))
+ (g422 g1400
+ g1452
+ g1451
+ g1398
+ g1399
+ g1386
+ g1388
+ g1455
+ g1453
+ g1454))
+ (g422 g1400
+ g1452
+ g1451
+ g1398
+ g1399
+ g1386
+ g1388
+ '#f
+ g1453
+ g1454)))))
+ (cons '("top-level module placeholder"
+ placeholder)
+ g1385)
+ (g304 '() '() '()))
+ (if (memv g1402
+ '(import-form))
+ (g441 g1400
+ g1398
+ g1399
+ (lambda (g1459)
+ (g431 g1386
+ g1388
+ (lambda ()
+ (begin (if g1397
+ (syntax-error
+ (g394 g1400
+ g1398
+ g1399)
+ '"not valid at top-level")
+ (void))
+ ((lambda (g1460)
+ ((lambda (g1461)
+ (if (memv g1461
+ '(module))
+ (g430 g1459
+ (g405 (g233 g1460)))
+ (if (memv g1461
+ '(displaced-lexical))
+ (g250 g1459)
+ (syntax-error
+ g1459
+ '"import from unknown module"))))
+ (g232 g1460)))
+ (g253 (g377 g1459
+ '(()))
+ '())))))))
+ ((lambda (g1462)
+ (begin (if (eq? g1386
+ 'c&e)
+ (g91 g1462)
+ (void))
+ g1462))
+ (g433 g1401
+ g1397
+ g1400
+ g1385
+ g1398
+ g1399))))))))))
+ g1401)))))
+ (g399
+ (lambda (g1099 g1096 g1098 g1097)
+ (call-with-values
+ (lambda () (g398 g1099 g1096 g1098 '#f g1097))
+ (lambda (g1104 g1100 g1103 g1101 g1102)
+ (g433 g1104 g1100 g1103 g1096 g1101 g1102)))))
+ (g398
+ (lambda (g1370 g1366 g1369 g1367 g1368)
+ (if (symbol? g1370)
+ ((lambda (g1371)
+ ((lambda (g1372)
+ ((lambda (g1373)
+ ((lambda ()
+ ((lambda (g1374)
+ (if (memv g1374 '(lexical))
+ (values
+ g1373
+ (g233 g1372)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1374 '(global))
+ (values
+ g1373
+ (g233 g1372)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1374 '(macro macro!))
+ (g398 (g436 (g233 g1372)
+ g1370
+ g1366
+ g1369
+ g1367
+ g1368)
+ g1366
+ '(())
+ '#f
+ g1368)
+ (values
+ g1373
+ (g233 g1372)
+ g1370
+ g1369
+ g1367)))))
+ g1373))))
+ (g232 g1372)))
+ (g253 g1371 g1366)))
+ (g377 g1370 g1369))
+ (if (pair? g1370)
+ ((lambda (g1375)
+ (if (g256 g1375)
+ ((lambda (g1376)
+ ((lambda (g1377)
+ ((lambda (g1378)
+ ((lambda ()
+ ((lambda (g1379)
+ (if (memv g1379 '(lexical))
+ (values
+ 'lexical-call
+ (g233 g1377)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(macro macro!))
+ (g398 (g436 (g233 g1377)
+ g1370
+ g1366
+ g1369
+ g1367
+ g1368)
+ g1366
+ '(())
+ '#f
+ g1368)
+ (if (memv g1379
+ '(core))
+ (values
+ g1378
+ (g233 g1377)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(local-syntax))
+ (values
+ 'local-syntax-form
+ (g233 g1377)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(begin))
+ (values
+ 'begin-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(eval-when))
+ (values
+ 'eval-when-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(define))
+ (values
+ 'define-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(define-syntax))
+ (values
+ 'define-syntax-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(module-key))
+ (values
+ 'module-form
+ '#f
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(import))
+ (values
+ 'import-form
+ (if (g233 g1377)
+ (g393 g1375
+ g1369)
+ '#f)
+ g1370
+ g1369
+ g1367)
+ (if (memv g1379
+ '(set!))
+ (g435 g1370
+ g1366
+ g1369
+ g1367
+ g1368)
+ (values
+ 'call
+ '#f
+ g1370
+ g1369
+ g1367)))))))))))))
+ g1378))))
+ (g232 g1377)))
+ (g253 g1376 g1366)))
+ (g377 g1375 g1369))
+ (values 'call '#f g1370 g1369 g1367)))
+ (car g1370))
+ (if (g204 g1370)
+ (g398 (g205 g1370)
+ g1366
+ (g371 g1369 (g206 g1370))
+ '#f
+ g1368)
+ (if (g90 g1370)
+ (g398 (annotation-expression g1370)
+ g1366
+ g1369
+ (annotation-source g1370)
+ g1368)
+ (if ((lambda (g1380)
+ ((lambda (g1381)
+ (if g1381
+ g1381
+ ((lambda (g1382)
+ (if g1382
+ g1382
+ ((lambda (g1383)
+ (if g1383
+ g1383
+ ((lambda (g1384)
+ (if g1384
+ g1384
+ (null?
+ g1380)))
+ (char?
+ g1380))))
+ (string? g1380))))
+ (number? g1380))))
+ (boolean? g1380)))
+ g1370)
+ (values 'constant '#f g1370 g1369 g1367)
+ (values
+ 'other
+ '#f
+ g1370
+ g1369
+ g1367))))))))
+ (g397
+ (lambda (g1107 g1105 g1106)
+ ((letrec ((g1108
+ (lambda (g1110 g1109)
+ (if (null? g1110)
+ g1109
+ (g1108
+ (cdr g1110)
+ (cons ((lambda (g1111)
+ (if (g378 g1111
+ '#(syntax-object
+ compile
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(when-list
+ situations)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e when-list w)
+ #((top)
+ (top)
+ (top))
+ #("i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ 'compile
+ (if (g378 g1111
+ '#(syntax-object
+ load
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(when-list
+ situations)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ when-list
+ w)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ 'load
+ (if (g378 g1111
+ '#(syntax-object
+ eval
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(when-list
+ situations)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ when-list
+ w)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip*
+ strip-annotation
+ ellipsis?
+ chi-void
+ chi-local-syntax
+ chi-lambda-clause
+ parse-define-syntax
+ parse-define
+ parse-import
+ parse-module
+ do-import!
+ chi-internal
+ chi-body
+ chi-macro
+ chi-set!
+ chi-application
+ chi-expr
+ chi
+ ct-eval/residualize
+ do-top-import
+ vfor-each
+ vmap
+ chi-external
+ check-defined-ids
+ check-module-exports
+ extend-store!
+ id-set-diff
+ chi-top-module
+ set-module-binding-val!
+ set-module-binding-imps!
+ set-module-binding-label!
+ set-module-binding-id!
+ set-module-binding-type!
+ module-binding-val
+ module-binding-imps
+ module-binding-label
+ module-binding-id
+ module-binding-type
+ module-binding?
+ make-module-binding
+ make-resolved-interface
+ make-trimmed-interface
+ set-interface-token!
+ set-interface-exports!
+ interface-token
+ interface-exports
+ interface?
+ make-interface
+ flatten-exports
+ chi-top
+ chi-top-expr
+ syntax-type
+ chi-when-list
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ invalid-ids-error
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ literal-id=?
+ free-id=?
+ id-var-name
+ id-var-name-loc
+ id-var-name&marks
+ id-var-name-loc&marks
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-trimmed-syntax-object
+ make-binding-wrap
+ lookup-import-binding-name
+ extend-ribcage-subst!
+ extend-ribcage-barrier-help!
+ extend-ribcage-barrier!
+ extend-ribcage!
+ make-empty-ribcage
+ import-token-key
+ import-token?
+ make-import-token
+ barrier-marker
+ new-mark
+ anti-mark
+ the-anti-mark
+ only-top-marked?
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ set-indirect-label!
+ get-indirect-label
+ indirect-label?
+ gen-indirect-label
+ gen-labels
+ label?
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ sanitize-binding
+ lookup*
+ displaced-lexical-error
+ transformer-env
+ extend-var-env*
+ extend-env*
+ extend-env
+ null-env
+ binding?
+ set-binding-value!
+ set-binding-type!
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ unannotate
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ self-evaluating?
+ build-lexical-var
+ build-letrec
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-cte-install
+ build-module-definition
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ generate-id
+ get-import-binding
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ error-hook
+ local-eval-hook
+ top-level-eval-hook
+ annotation?
+ fx<
+ fx=
+ fx-
+ fx+
+ noexpand
+ define-structure
+ unless
+ when)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i" "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ 'eval
+ (syntax-error
+ (g393 g1111 g1106)
+ '"invalid eval-when situation")))))
+ (car g1110))
+ g1109))))))
+ g1108)
+ g1105
+ '())))
+ (g396
+ (lambda (g1358 g1352 g1357 g1353 g1356 g1354 g1355)
+ (g190 g1353
+ ((letrec ((g1359
+ (lambda (g1364 g1360 g1363 g1361 g1362)
+ (if (null? g1364)
+ '()
+ ((lambda (g1365)
+ (cons g1365
+ (g1359
+ (cdr g1364)
+ g1360
+ g1363
+ g1361
+ g1362)))
+ (g400 (car g1364)
+ g1360
+ g1363
+ g1361
+ g1362
+ g1355))))))
+ g1359)
+ g1358
+ g1352
+ g1357
+ g1356
+ g1354))))
+ (g395
+ (lambda (g1115 g1112 g1114 g1113)
+ (g190 g1113
+ ((letrec ((g1116
+ (lambda (g1119 g1117 g1118)
+ (if (null? g1119)
+ '()
+ ((lambda (g1120)
+ (cons g1120
+ (g1116
+ (cdr g1119)
+ g1117
+ g1118)))
+ (g432 (car g1119) g1117 g1118))))))
+ g1116)
+ g1115
+ g1112
+ g1114))))
+ (g394
+ (lambda (g1351 g1349 g1350)
+ (g393 (if g1350 (make-annotation g1351 g1350 '#f) g1351)
+ g1349)))
+ (g393
+ (lambda (g1122 g1121)
+ (if (if (null? (g264 g1121)) (null? (g265 g1121)) '#f)
+ g1122
+ (if (g204 g1122)
+ (g203 (g205 g1122) (g371 g1121 (g206 g1122)))
+ (if (null? g1122) g1122 (g203 g1122 g1121))))))
+ (g392
+ (lambda (g1347 g1346)
+ (if (not (null? g1346))
+ ((lambda (g1348)
+ (if g1348 g1348 (g392 g1347 (cdr g1346))))
+ (g388 g1347 (car g1346)))
+ '#f)))
+ (g391
+ (lambda (g1125 g1123 g1124)
+ ((letrec ((g1126
+ (lambda (g1128 g1127)
+ (if (null? g1128)
+ (syntax-error g1123)
+ (if (g256 (car g1128))
+ (if (g392 (car g1128) g1127)
+ (syntax-error
+ (car g1128)
+ '"duplicate "
+ g1124)
+ (g1126
+ (cdr g1128)
+ (cons (car g1128) g1127)))
+ (syntax-error
+ (car g1128)
+ '"invalid "
+ g1124))))))
+ g1126)
+ g1125
+ '())))
+ (g390
+ (lambda (g1342)
+ ((letrec ((g1343
+ (lambda (g1344)
+ ((lambda (g1345)
+ (if g1345
+ g1345
+ (if (not (g392 (car g1344) (cdr g1344)))
+ (g1343 (cdr g1344))
+ '#f)))
+ (null? g1344)))))
+ g1343)
+ g1342)))
+ (g389
+ (lambda (g1129)
+ (if ((letrec ((g1130
+ (lambda (g1131)
+ ((lambda (g1132)
+ (if g1132
+ g1132
+ (if (g256 (car g1131))
+ (g1130 (cdr g1131))
+ '#f)))
+ (null? g1131)))))
+ g1130)
+ g1129)
+ (g390 g1129)
+ '#f)))
+ (g388
+ (lambda (g1337 g1336)
+ (if (if (g204 g1337) (g204 g1336) '#f)
+ (if (eq? ((lambda (g1339)
+ (if (g90 g1339)
+ (annotation-expression g1339)
+ g1339))
+ (g205 g1337))
+ ((lambda (g1338)
+ (if (g90 g1338)
+ (annotation-expression g1338)
+ g1338))
+ (g205 g1336)))
+ (g373 (g264 (g206 g1337)) (g264 (g206 g1336)))
+ '#f)
+ (eq? ((lambda (g1341)
+ (if (g90 g1341)
+ (annotation-expression g1341)
+ g1341))
+ g1337)
+ ((lambda (g1340)
+ (if (g90 g1340)
+ (annotation-expression g1340)
+ g1340))
+ g1336)))))
+ (g378
+ (lambda (g1134 g1133)
+ (if (eq? ((lambda (g1137)
+ ((lambda (g1138)
+ (if (g90 g1138)
+ (annotation-expression g1138)
+ g1138))
+ (if (g204 g1137) (g205 g1137) g1137)))
+ g1134)
+ ((lambda (g1135)
+ ((lambda (g1136)
+ (if (g90 g1136)
+ (annotation-expression g1136)
+ g1136))
+ (if (g204 g1135) (g205 g1135) g1135)))
+ g1133))
+ (eq? (g377 g1134 '(())) (g377 g1133 '(())))
+ '#f)))
+ (g377
+ (lambda (g1333 g1332)
+ (call-with-values
+ (lambda () (g374 g1333 g1332))
+ (lambda (g1335 g1334)
+ (if (g301 g1335) (g302 g1335) g1335)))))
+ (g376
+ (lambda (g1140 g1139)
+ (call-with-values
+ (lambda () (g374 g1140 g1139))
+ (lambda (g1142 g1141) g1142))))
+ (g375
+ (lambda (g1329 g1328)
+ (call-with-values
+ (lambda () (g374 g1329 g1328))
+ (lambda (g1331 g1330)
+ (values (if (g301 g1331) (g302 g1331) g1331) g1330)))))
+ (g374
+ (lambda (g1144 g1143)
+ (letrec ((g1147
+ (lambda (g1174 g1170 g1173 g1171 g1172)
+ ((lambda (g1175)
+ ((letrec ((g1176
+ (lambda (g1177)
+ (if (= g1177 g1175)
+ (g1145
+ g1174
+ (cdr g1170)
+ g1173)
+ (if (if (eq? (vector-ref
+ g1171
+ g1177)
+ g1174)
+ (g373 g1173
+ (vector-ref
+ (g307 g1172)
+ g1177))
+ '#f)
+ (values
+ (vector-ref
+ (g308 g1172)
+ g1177)
+ g1173)
+ (g1176 (+ g1177 '1)))))))
+ g1176)
+ '0))
+ (vector-length g1171))))
+ (g1146
+ (lambda (g1159 g1155 g1158 g1156 g1157)
+ ((letrec ((g1160
+ (lambda (g1162 g1161)
+ (if (null? g1162)
+ (g1145 g1159 (cdr g1155) g1158)
+ (if (if (eq? (car g1162) g1159)
+ (g373 g1158
+ (list-ref
+ (g307 g1157)
+ g1161))
+ '#f)
+ (values
+ (list-ref
+ (g308 g1157)
+ g1161)
+ g1158)
+ (if (g357 (car g1162))
+ ((lambda (g1163)
+ (if g1163
+ ((lambda (g1164)
+ (if (symbol?
+ g1164)
+ (values
+ g1164
+ g1158)
+ (g375 g1164
+ '(()))))
+ g1163)
+ (g1160
+ (cdr g1162)
+ g1161)))
+ (g367 g1159
+ (g358 (car g1162))
+ g1158))
+ (if (if (eq? (car g1162)
+ g354)
+ (g373 g1158
+ (list-ref
+ (g307 g1157)
+ g1161))
+ '#f)
+ (values '#f g1158)
+ (g1160
+ (cdr g1162)
+ (+ g1161
+ '1)))))))))
+ g1160)
+ g1156
+ '0)))
+ (g1145
+ (lambda (g1167 g1165 g1166)
+ (if (null? g1165)
+ (values g1167 g1166)
+ ((lambda (g1168)
+ (if (eq? g1168 'shift)
+ (g1145 g1167 (cdr g1165) (cdr g1166))
+ ((lambda (g1169)
+ (if (vector? g1169)
+ (g1147
+ g1167
+ g1165
+ g1166
+ g1169
+ g1168)
+ (g1146
+ g1167
+ g1165
+ g1166
+ g1169
+ g1168)))
+ (g306 g1168))))
+ (car g1165))))))
+ (if (symbol? g1144)
+ (g1145 g1144 (g265 g1143) (g264 g1143))
+ (if (g204 g1144)
+ ((lambda (g1149 g1148)
+ ((lambda (g1150)
+ (call-with-values
+ (lambda ()
+ (g1145 g1149 (g265 g1143) g1150))
+ (lambda (g1152 g1151)
+ (if (eq? g1152 g1149)
+ (g1145 g1149 (g265 g1148) g1151)
+ (values g1152 g1151)))))
+ (g372 (g264 g1143) (g264 g1148))))
+ ((lambda (g1153)
+ (if (g90 g1153)
+ (annotation-expression g1153)
+ g1153))
+ (g205 g1144))
+ (g206 g1144))
+ (if (g90 g1144)
+ (g1145
+ ((lambda (g1154)
+ (if (g90 g1154)
+ (annotation-expression g1154)
+ g1154))
+ g1144)
+ (g265 g1143)
+ (g264 g1143))
+ (g93 'id-var-name '"invalid id" g1144)))))))
+ (g373
+ (lambda (g1326 g1325)
+ ((lambda (g1327)
+ (if g1327
+ g1327
+ (if (not (null? g1326))
+ (if (not (null? g1325))
+ (if (eq? (car g1326) (car g1325))
+ (g373 (cdr g1326) (cdr g1325))
+ '#f)
+ '#f)
+ '#f)))
+ (eq? g1326 g1325))))
+ (g372 (lambda (g1179 g1178) (g370 g1179 g1178)))
+ (g371
+ (lambda (g1322 g1321)
+ ((lambda (g1324 g1323)
+ (if (null? g1324)
+ (if (null? g1323)
+ g1321
+ (g263 (g264 g1321) (g370 g1323 (g265 g1321))))
+ (g263 (g370 g1324 (g264 g1321))
+ (g370 g1323 (g265 g1321)))))
+ (g264 g1322)
+ (g265 g1322))))
+ (g370
+ (lambda (g1181 g1180)
+ (if (null? g1180) g1181 (append g1181 g1180))))
+ (g369
+ (lambda (g1315)
+ (call-with-values
+ (lambda () (g375 g1315 '(())))
+ (lambda (g1317 g1316)
+ (begin (if (not g1317)
+ (syntax-error
+ g1315
+ '"identifier not visible for export")
+ (void))
+ ((lambda (g1318)
+ (g203 g1318
+ (g263 g1316
+ (list (g304 (vector g1318)
+ (vector g1316)
+ (vector g1317))))))
+ ((lambda (g1319)
+ ((lambda (g1320)
+ (if (g90 g1320)
+ (annotation-expression g1320)
+ g1320))
+ (if (g204 g1319) (g205 g1319) g1319)))
+ g1315)))))))
+ (g368
+ (lambda (g1184 g1182 g1183)
+ (if (null? g1184)
+ g1183
+ (g263 (g264 g1183)
+ (cons ((lambda (g1185)
+ ((lambda (g1186)
+ ((lambda (g1188 g1187)
+ (begin ((letrec ((g1189
+ (lambda (g1191
+ g1190)
+ (if (not (null?
+ g1191))
+ (call-with-values
+ (lambda ()
+ (g262 (car g1191)
+ g1183))
+ (lambda (g1193
+ g1192)
+ (begin (vector-set!
+ g1188
+ g1190
+ g1193)
+ (vector-set!
+ g1187
+ g1190
+ g1192)
+ (g1189
+ (cdr g1191)
+ (+ g1190
+ '1)))))
+ (void)))))
+ g1189)
+ g1184
+ '0)
+ (g304 g1188 g1187 g1185)))
+ (make-vector g1186)
+ (make-vector g1186)))
+ (vector-length g1185)))
+ (list->vector g1182))
+ (g265 g1183))))))
+ (g367
+ (lambda (g1310 g1308 g1309)
+ ((lambda (g1311)
+ (if g1311
+ ((letrec ((g1312
+ (lambda (g1313)
+ (if (pair? g1313)
+ ((lambda (g1314)
+ (if g1314
+ g1314
+ (g1312 (cdr g1313))))
+ (g1312 (car g1313)))
+ (if (g373 g1309 (g264 (g206 g1313)))
+ g1313
+ '#f)))))
+ g1312)
+ g1311)
+ '#f))
+ (g100 g1310 g1308))))
+ (g366
+ (lambda (g1195 g1194)
+ (g309 g1195 (cons (g356 g1194) (g306 g1195)))))
+ (g365
+ (lambda (g1307 g1306)
+ (begin (g309 g1307 (cons g354 (g306 g1307)))
+ (g310 g1307 (cons (g264 g1306) (g307 g1307))))))
+ (g364 (lambda (g1197 g1196) (g365 g1197 (g206 g1196))))
+ (g363
+ (lambda (g1304 g1302 g1303)
+ (begin (g309 g1304
+ (cons ((lambda (g1305)
+ (if (g90 g1305)
+ (annotation-expression g1305)
+ g1305))
+ (g205 g1302))
+ (g306 g1304)))
+ (g310 g1304 (cons (g264 (g206 g1302)) (g307 g1304)))
+ (g311 g1304 (cons g1303 (g308 g1304))))))
+ (g358 cdr)
+ (g357
+ (lambda (g1301)
+ (if (pair? g1301) (eq? (car g1301) g355) '#f)))
+ (g356 (lambda (g1198) (cons g355 g1198)))
+ (g355 'import-token)
+ (g354 '#f)
+ (g349
+ (lambda (g1300)
+ (g263 (cons '#f (g264 g1300)) (cons 'shift (g265 g1300)))))
+ (g311 (lambda (g1200 g1199) (vector-set! g1200 '3 g1199)))
+ (g310 (lambda (g1299 g1298) (vector-set! g1299 '2 g1298)))
+ (g309 (lambda (g1202 g1201) (vector-set! g1202 '1 g1201)))
+ (g308 (lambda (g1297) (vector-ref g1297 '3)))
+ (g307 (lambda (g1203) (vector-ref g1203 '2)))
+ (g306 (lambda (g1296) (vector-ref g1296 '1)))
+ (g305
+ (lambda (g1204)
+ (if (vector? g1204)
+ (if (= (vector-length g1204) '4)
+ (eq? (vector-ref g1204 '0) 'ribcage)
+ '#f)
+ '#f)))
+ (g304
+ (lambda (g1295 g1293 g1294)
+ (vector 'ribcage g1295 g1293 g1294)))
+ (g303 set-car!)
+ (g302 car)
+ (g301 pair?)
+ (g300 (lambda () (list (g297))))
+ (g299
+ (lambda (g1205)
+ (if (null? g1205) '() (cons (g297) (g299 (cdr g1205))))))
+ (g298
+ (lambda (g1290)
+ ((lambda (g1291)
+ (if g1291
+ g1291
+ ((lambda (g1292) (if g1292 g1292 (g301 g1290)))
+ (symbol? g1290))))
+ (string? g1290))))
+ (g297 (lambda () (string '#\i)))
+ (g265 cdr)
+ (g264 car)
+ (g263 cons)
+ (g262
+ (lambda (g1207 g1206)
+ (if (g204 g1207)
+ (values
+ ((lambda (g1208)
+ (if (g90 g1208)
+ (annotation-expression g1208)
+ g1208))
+ (g205 g1207))
+ (g372 (g264 g1206) (g264 (g206 g1207))))
+ (values
+ ((lambda (g1209)
+ (if (g90 g1209)
+ (annotation-expression g1209)
+ g1209))
+ g1207)
+ (g264 g1206)))))
+ (g256
+ (lambda (g1288)
+ (if (symbol? g1288)
+ '#t
+ (if (g204 g1288)
+ (symbol?
+ ((lambda (g1289)
+ (if (g90 g1289)
+ (annotation-expression g1289)
+ g1289))
+ (g205 g1288)))
+ (if (g90 g1288)
+ (symbol? (annotation-expression g1288))
+ '#f)))))
+ (g255
+ (lambda (g1210)
+ (if (g204 g1210)
+ (symbol?
+ ((lambda (g1211)
+ (if (g90 g1211)
+ (annotation-expression g1211)
+ g1211))
+ (g205 g1210)))
+ '#f)))
+ (g254
+ (lambda (g1287 g1285 g1286) (g98 g1285 (g231 g1287 g1286))))
+ (g253
+ (lambda (g1213 g1212)
+ (letrec ((g1214
+ (lambda (g1221 g1220)
+ (begin (g234 g1221 (g232 g1220))
+ (g235 g1221 (g233 g1220))))))
+ ((lambda (g1215)
+ ((lambda (g1216)
+ (if (memv g1216 '(deferred))
+ (begin (g1214
+ g1215
+ ((lambda (g1217)
+ ((lambda (g1218)
+ (if g1218
+ g1218
+ (syntax-error
+ g1217
+ '"invalid transformer")))
+ (g252 g1217)))
+ (g92 (g233 g1215))))
+ ((lambda (g1219) g1215) (g232 g1215)))
+ g1215))
+ (g232 g1215)))
+ (g251 g1213 g1212)))))
+ (g252
+ (lambda (g1283)
+ (if (procedure? g1283)
+ (g231 'macro g1283)
+ (if (g236 g1283)
+ ((lambda (g1284)
+ (if (memv g1284 '(core macro macro!))
+ (if (procedure? (g233 g1283)) g1283 '#f)
+ (if (memv g1284 '(module))
+ (if (g403 (g233 g1283)) g1283 '#f)
+ g1283)))
+ (g232 g1283))
+ '#f))))
+ (g251
+ (lambda (g1223 g1222)
+ ((lambda (g1224)
+ (if g1224
+ (cdr g1224)
+ (if (symbol? g1223)
+ ((lambda (g1225)
+ (if g1225 g1225 (g231 'global g1223)))
+ (g99 g1223))
+ (g231 'displaced-lexical '#f))))
+ (assq g1223 g1222))))
+ (g250
+ (lambda (g1282)
+ (syntax-error
+ g1282
+ (if (g377 g1282 '(()))
+ '"identifier out of context"
+ '"identifier not visible"))))
+ (g249
+ (lambda (g1226)
+ (if (null? g1226)
+ '()
+ ((lambda (g1227)
+ (if (eq? (cadr g1227) 'lexical)
+ (g249 (cdr g1226))
+ (cons g1227 (g249 (cdr g1226)))))
+ (car g1226)))))
+ (g248
+ (lambda (g1281 g1279 g1280)
+ (if (null? g1281)
+ g1280
+ (g248 (cdr g1281)
+ (cdr g1279)
+ (g246 (car g1281)
+ (g231 'lexical (car g1279))
+ g1280)))))
+ (g247
+ (lambda (g1230 g1228 g1229)
+ (if (null? g1230)
+ g1229
+ (g247 (cdr g1230)
+ (cdr g1228)
+ (g246 (car g1230) (car g1228) g1229)))))
+ (g246
+ (lambda (g1278 g1276 g1277)
+ (cons (cons g1278 g1276) g1277)))
+ (g236
+ (lambda (g1231)
+ (if (pair? g1231) (symbol? (car g1231)) '#f)))
+ (g235 set-cdr!)
+ (g234 set-car!)
+ (g233 cdr)
+ (g232 car)
+ (g231 (lambda (g1275 g1274) (cons g1275 g1274)))
+ (g223
+ (lambda (g1232)
+ (if (g90 g1232)
+ (annotation-source g1232)
+ (if (g204 g1232) (g223 (g205 g1232)) '#f))))
+ (g208 (lambda (g1273 g1272) (vector-set! g1273 '2 g1272)))
+ (g207 (lambda (g1234 g1233) (vector-set! g1234 '1 g1233)))
+ (g206 (lambda (g1271) (vector-ref g1271 '2)))
+ (g205 (lambda (g1235) (vector-ref g1235 '1)))
+ (g204
+ (lambda (g1270)
+ (if (vector? g1270)
+ (if (= (vector-length g1270) '3)
+ (eq? (vector-ref g1270 '0) 'syntax-object)
+ '#f)
+ '#f)))
+ (g203
+ (lambda (g1237 g1236) (vector 'syntax-object g1237 g1236)))
+ (g191
+ (lambda (g1269 g1266 g1268 g1267)
+ (if (null? g1266)
+ g1267
+ (list 'letrec (map list g1266 g1268) g1267))))
+ (g190
+ (lambda (g1239 g1238)
+ (if (null? (cdr g1238)) (car g1238) (cons 'begin g1238))))
+ (g101
+ ((lambda (g1251)
+ (letrec ((g1254
+ (lambda (g1260)
+ ((letrec ((g1261
+ (lambda (g1263 g1262)
+ (if (< g1263 g1251)
+ (list->string
+ (cons (g1253 g1263) g1262))
+ ((lambda (g1265 g1264)
+ (g1261
+ g1264
+ (cons (g1253 g1265)
+ g1262)))
+ (modulo g1263 g1251)
+ (quotient g1263 g1251))))))
+ g1261)
+ g1260
+ '())))
+ (g1253
+ (lambda (g1259) (integer->char (+ g1259 '33))))
+ (g1252 (lambda () '0)))
+ ((lambda (g1256 g1255)
+ (lambda (g1257)
+ (begin (set! g1255 (+ g1255 '1))
+ ((lambda (g1258) g1258)
+ (string->symbol
+ (string-append
+ '"#"
+ g1256
+ (g1254 g1255)))))))
+ (g1254 (g1252))
+ '-1)))
+ (- '127 '32 '2)))
+ (g100 (lambda (g1241 g1240) (getprop g1241 g1240)))
+ (g99 (lambda (g1250) (getprop g1250 '*sc-expander*)))
+ (g98 (lambda (g1243 g1242) ($sc-put-cte g1243 g1242)))
+ (g93
+ (lambda (g1249 g1247 g1248)
+ (error g1249 '"~a ~s" g1247 g1248)))
+ (g92 (lambda (g1244) (eval (list g53 g1244))))
+ (g91 (lambda (g1246) (eval (list g53 g1246))))
+ (g90 (lambda (g1245) '#f))
+ (g53 '"noexpand"))
+ (begin (set! $sc-put-cte
+ (lambda (g802 g801)
+ (letrec ((g805
+ (lambda (g831 g830)
+ ((lambda (g832)
+ (putprop g832 '*sc-expander* g830))
+ (if (symbol? g831) g831 (g377 g831 '(()))))))
+ (g804
+ (lambda (g815 g814)
+ (g429 (lambda (g816) (g803 g816 g814)) g815)))
+ (g803
+ (lambda (g818 g817)
+ (letrec ((g820
+ (lambda (g828 g827)
+ (if (pair? g827)
+ (if (g388 (car g827) g828)
+ (g820 g828 (cdr g827))
+ (g819 (car g827)
+ (g820 g828
+ (cdr g827))))
+ (if ((lambda (g829)
+ (if g829
+ g829
+ (g388 g827 g828)))
+ (not g827))
+ '#f
+ g827))))
+ (g819
+ (lambda (g826 g825)
+ (if (not g825)
+ g826
+ (cons g826 g825)))))
+ ((lambda (g821)
+ ((lambda (g822)
+ (if (if (not g822) (symbol? g818) '#f)
+ (remprop g821 g817)
+ (putprop
+ g821
+ g817
+ (g819 g818 g822))))
+ (g820 g818 (getprop g821 g817))))
+ ((lambda (g823)
+ ((lambda (g824)
+ (if (g90 g824)
+ (annotation-expression g824)
+ g824))
+ (if (g204 g823) (g205 g823) g823)))
+ g818))))))
+ ((lambda (g806)
+ ((lambda (g807)
+ (if (memv g807 '(module))
+ (begin ((lambda (g808)
+ (g804 (g404 g808) (g405 g808)))
+ (g233 g806))
+ (g805 g802 g806))
+ (if (memv g807 '(do-import))
+ ((lambda (g809)
+ ((lambda (g810)
+ ((lambda (g811)
+ (if (memv g811 '(module))
+ ((lambda (g812)
+ (begin (if (not (eq? (g405 g812)
+ g809))
+ (syntax-error
+ g802
+ '"import mismatch for module")
+ (void))
+ (g804 (g404 g812)
+ '*top*)))
+ (g233 g810))
+ (syntax-error
+ g802
+ '"import from unknown module")))
+ (g232 g810)))
+ (g253 (g377 g802 '(())) '())))
+ (g233 g801))
+ (g805 g802 g806))))
+ (g232 g806)))
+ ((lambda (g813)
+ (if g813
+ g813
+ (error 'define-syntax
+ '"invalid transformer ~s"
+ g801)))
+ (g252 g801))))))
+ (g254 'local-syntax 'letrec-syntax '#t)
+ (g254 'local-syntax 'let-syntax '#f)
+ (g254 'core
+ 'fluid-let-syntax
+ (lambda (g456 g453 g455 g454)
+ ((lambda (g457)
+ ((lambda (g458)
+ (if (if g458
+ (apply
+ (lambda (g463 g459 g462 g460 g461)
+ (g389 g459))
+ g458)
+ '#f)
+ (apply
+ (lambda (g469 g465 g468 g466 g467)
+ ((lambda (g470)
+ (begin (for-each
+ (lambda (g477 g476)
+ ((lambda (g478)
+ (if (memv g478
+ '(displaced-lexical))
+ (g250 (g393 g477
+ g455))
+ (void)))
+ (g232 (g253 g476 g453))))
+ g465
+ g470)
+ (g437 (cons g466 g467)
+ (g394 g456 g455 g454)
+ (g247 g470
+ ((lambda (g471)
+ (map (lambda (g473)
+ (g231 'deferred
+ (g432 g473
+ g471
+ g455)))
+ g468))
+ (g249 g453))
+ g453)
+ g455)))
+ (map (lambda (g480) (g377 g480 g455))
+ g465)))
+ g458)
+ ((lambda (g481)
+ (syntax-error (g394 g456 g455 g454)))
+ g457)))
+ ($syntax-dispatch
+ g457
+ '(any #(each (any any)) any . each-any))))
+ g456)))
+ (g254 'core
+ 'quote
+ (lambda (g795 g792 g794 g793)
+ ((lambda (g796)
+ ((lambda (g797)
+ (if g797
+ (apply
+ (lambda (g799 g798)
+ (list 'quote (g450 g798 g794)))
+ g797)
+ ((lambda (g800)
+ (syntax-error (g394 g795 g794 g793)))
+ g796)))
+ ($syntax-dispatch g796 '(any any))))
+ g795)))
+ (g254 'core
+ 'syntax
+ ((lambda ()
+ (letrec ((g489
+ (lambda (g584)
+ ((lambda (g585)
+ (if (memv g585 '(ref))
+ (cadr g584)
+ (if (memv g585 '(primitive))
+ (cadr g584)
+ (if (memv g585 '(quote))
+ (list 'quote (cadr g584))
+ (if (memv g585 '(lambda))
+ (list 'lambda
+ (cadr g584)
+ (g489 (caddr
+ g584)))
+ (if (memv g585 '(map))
+ ((lambda (g586)
+ (cons (if (= (length
+ g586)
+ '2)
+ 'map
+ 'map)
+ g586))
+ (map g489
+ (cdr g584)))
+ (cons (car g584)
+ (map g489
+ (cdr g584)))))))))
+ (car g584))))
+ (g488
+ (lambda (g502)
+ (if (eq? (car g502) 'list)
+ (cons 'vector (cdr g502))
+ (if (eq? (car g502) 'quote)
+ (list 'quote
+ (list->vector (cadr g502)))
+ (list 'list->vector g502)))))
+ (g487
+ (lambda (g583 g582)
+ (if (equal? g582 ''())
+ g583
+ (list 'append g583 g582))))
+ (g486
+ (lambda (g504 g503)
+ ((lambda (g505)
+ (if (memv g505 '(quote))
+ (if (eq? (car g504) 'quote)
+ (list 'quote
+ (cons (cadr g504)
+ (cadr g503)))
+ (if (eq? (cadr g503) '())
+ (list 'list g504)
+ (list 'cons g504 g503)))
+ (if (memv g505 '(list))
+ (cons 'list
+ (cons g504 (cdr g503)))
+ (list 'cons g504 g503))))
+ (car g503))))
+ (g485
+ (lambda (g575 g574)
+ ((lambda (g577 g576)
+ (if (eq? (car g575) 'ref)
+ (car g576)
+ (if (andmap
+ (lambda (g578)
+ (if (eq? (car g578) 'ref)
+ (memq (cadr g578) g577)
+ '#f))
+ (cdr g575))
+ (cons 'map
+ (cons (list 'primitive
+ (car g575))
+ (map ((lambda (g579)
+ (lambda (g580)
+ (cdr (assq (cadr g580)
+ g579))))
+ (map cons
+ g577
+ g576))
+ (cdr g575))))
+ (cons 'map
+ (cons (list 'lambda
+ g577
+ g575)
+ g576)))))
+ (map cdr g574)
+ (map (lambda (g581)
+ (list 'ref (car g581)))
+ g574))))
+ (g484
+ (lambda (g507 g506)
+ (list 'apply
+ '(primitive append)
+ (g485 g507 g506))))
+ (g483
+ (lambda (g569 g566 g568 g567)
+ (if (= g568 '0)
+ (values g566 g567)
+ (if (null? g567)
+ (syntax-error
+ g569
+ '"missing ellipsis in syntax form")
+ (call-with-values
+ (lambda ()
+ (g483 g569
+ g566
+ (- g568 '1)
+ (cdr g567)))
+ (lambda (g571 g570)
+ ((lambda (g572)
+ (if g572
+ (values
+ (cdr g572)
+ g567)
+ ((lambda (g573)
+ (values
+ g573
+ (cons (cons (cons g571
+ g573)
+ (car g567))
+ g570)))
+ (g451 'tmp))))
+ (assq g571 (car g567)))))))))
+ (g482
+ (lambda (g512 g508 g511 g509 g510)
+ (if (g256 g508)
+ ((lambda (g513)
+ ((lambda (g514)
+ (if (eq? (g232 g514) 'syntax)
+ (call-with-values
+ (lambda ()
+ ((lambda (g517)
+ (g483 g512
+ (car g517)
+ (cdr g517)
+ g509))
+ (g233 g514)))
+ (lambda (g516 g515)
+ (values
+ (list 'ref g516)
+ g515)))
+ (if (g510 g508)
+ (syntax-error
+ g512
+ '"misplaced ellipsis in syntax form")
+ (values
+ (list 'quote g508)
+ g509))))
+ (g253 g513 g511)))
+ (g377 g508 '(())))
+ ((lambda (g518)
+ ((lambda (g519)
+ (if (if g519
+ (apply
+ (lambda (g521 g520)
+ (g510 g521))
+ g519)
+ '#f)
+ (apply
+ (lambda (g523 g522)
+ (g482 g512
+ g522
+ g511
+ g509
+ (lambda (g524)
+ '#f)))
+ g519)
+ ((lambda (g525)
+ (if (if g525
+ (apply
+ (lambda (g528
+ g526
+ g527)
+ (g510 g526))
+ g525)
+ '#f)
+ (apply
+ (lambda (g531
+ g529
+ g530)
+ ((letrec ((g532
+ (lambda (g534
+ g533)
+ ((lambda (g535)
+ ((lambda (g536)
+ (if (if g536
+ (apply
+ (lambda (g538
+ g537)
+ (g510 g538))
+ g536)
+ '#f)
+ (apply
+ (lambda (g540
+ g539)
+ (g532 g539
+ (lambda (g541)
+ (call-with-values
+ (lambda ()
+ (g533 (cons '()
+ g541)))
+ (lambda (g543
+ g542)
+ (if (null?
+ (car g542))
+ (syntax-error
+ g512
+ '"extra ellipsis in syntax form")
+ (values
+ (g484 g543
+ (car g542))
+ (cdr g542))))))))
+ g536)
+ ((lambda (g544)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ g534
+ g511
+ g509
+ g510))
+ (lambda (g546
+ g545)
+ (call-with-values
+ (lambda ()
+ (g533 g545))
+ (lambda (g548
+ g547)
+ (values
+ (g487 g548
+ g546)
+ g547))))))
+ g535)))
+ ($syntax-dispatch
+ g535
+ '(any .
+ any))))
+ g534))))
+ g532)
+ g530
+ (lambda (g549)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ g531
+ g511
+ (cons '()
+ g549)
+ g510))
+ (lambda (g551
+ g550)
+ (if (null?
+ (car g550))
+ (syntax-error
+ g512
+ '"extra ellipsis in syntax form")
+ (values
+ (g485 g551
+ (car g550))
+ (cdr g550))))))))
+ g525)
+ ((lambda (g552)
+ (if g552
+ (apply
+ (lambda (g554
+ g553)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ g554
+ g511
+ g509
+ g510))
+ (lambda (g556
+ g555)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ g553
+ g511
+ g555
+ g510))
+ (lambda (g558
+ g557)
+ (values
+ (g486 g556
+ g558)
+ g557))))))
+ g552)
+ ((lambda (g559)
+ (if g559
+ (apply
+ (lambda (g561
+ g560)
+ (call-with-values
+ (lambda ()
+ (g482 g512
+ (cons g561
+ g560)
+ g511
+ g509
+ g510))
+ (lambda (g563
+ g562)
+ (values
+ (g488 g563)
+ g562))))
+ g559)
+ ((lambda (g565)
+ (values
+ (list 'quote
+ g508)
+ g509))
+ g518)))
+ ($syntax-dispatch
+ g518
+ '#(vector
+ (any .
+ each-any))))))
+ ($syntax-dispatch
+ g518
+ '(any . any)))))
+ ($syntax-dispatch
+ g518
+ '(any any . any)))))
+ ($syntax-dispatch
+ g518
+ '(any any))))
+ g508)))))
+ (lambda (g493 g490 g492 g491)
+ ((lambda (g494)
+ ((lambda (g495)
+ ((lambda (g496)
+ (if g496
+ (apply
+ (lambda (g498 g497)
+ (call-with-values
+ (lambda ()
+ (g482 g494
+ g497
+ g490
+ '()
+ g447))
+ (lambda (g500 g499)
+ (g489 g500))))
+ g496)
+ ((lambda (g501) (syntax-error g494))
+ g495)))
+ ($syntax-dispatch g495 '(any any))))
+ g494))
+ (g394 g493 g492 g491)))))))
+ (g254 'core
+ 'lambda
+ (lambda (g785 g782 g784 g783)
+ ((lambda (g786)
+ ((lambda (g787)
+ (if g787
+ (apply
+ (lambda (g789 g788)
+ (g444 (g394 g785 g784 g783)
+ g788
+ g782
+ g784
+ (lambda (g791 g790)
+ (list 'lambda g791 g790))))
+ g787)
+ (syntax-error g786)))
+ ($syntax-dispatch g786 '(any . any))))
+ g785)))
+ (g254 'core
+ 'letrec
+ (lambda (g590 g587 g589 g588)
+ ((lambda (g591)
+ ((lambda (g592)
+ (if g592
+ (apply
+ (lambda (g597 g593 g596 g594 g595)
+ ((lambda (g598)
+ (if (not (g389 g598))
+ (g391 (map (lambda (g599)
+ (g393 g599 g589))
+ g598)
+ (g394 g590 g589 g588)
+ '"bound variable")
+ ((lambda (g601 g600)
+ ((lambda (g603 g602)
+ (g191 g588
+ g600
+ (map (lambda (g606)
+ (g432 g606
+ g602
+ g603))
+ g596)
+ (g437 (cons g594 g595)
+ (g394 g590
+ g603
+ g588)
+ g602
+ g603)))
+ (g368 g598 g601 g589)
+ (g248 g601 g600 g587)))
+ (g299 g598)
+ (map g451 g598))))
+ g593))
+ g592)
+ ((lambda (g608)
+ (syntax-error (g394 g590 g589 g588)))
+ g591)))
+ ($syntax-dispatch
+ g591
+ '(any #(each (any any)) any . each-any))))
+ g590)))
+ (g254 'core
+ 'if
+ (lambda (g770 g767 g769 g768)
+ ((lambda (g771)
+ ((lambda (g772)
+ (if g772
+ (apply
+ (lambda (g775 g773 g774)
+ (list 'if
+ (g432 g773 g767 g769)
+ (g432 g774 g767 g769)
+ (g446)))
+ g772)
+ ((lambda (g776)
+ (if g776
+ (apply
+ (lambda (g780 g777 g779 g778)
+ (list 'if
+ (g432 g777 g767 g769)
+ (g432 g779 g767 g769)
+ (g432 g778 g767 g769)))
+ g776)
+ ((lambda (g781)
+ (syntax-error
+ (g394 g770 g769 g768)))
+ g771)))
+ ($syntax-dispatch
+ g771
+ '(any any any any)))))
+ ($syntax-dispatch g771 '(any any any))))
+ g770)))
+ (g254 'set! 'set! '())
+ (g254 'begin 'begin '())
+ (g254 'module-key 'module '())
+ (g254 'import 'import '#f)
+ (g254 'import 'import-only '#t)
+ (g254 'define 'define '())
+ (g254 'define-syntax 'define-syntax '())
+ (g254 'eval-when 'eval-when '())
+ (g254 'core
+ 'syntax-case
+ ((lambda ()
+ (letrec ((g612
+ (lambda (g693 g690 g692 g691)
+ (if (null? g692)
+ (list 'syntax-error g693)
+ ((lambda (g694)
+ ((lambda (g695)
+ (if g695
+ (apply
+ (lambda (g697 g696)
+ (if (if (g256 g697)
+ (if (not (g392 g697
+ g690))
+ (not (g447 g697))
+ '#f)
+ '#f)
+ ((lambda (g699 g698)
+ (list (list 'lambda
+ (list g698)
+ (g432 g696
+ (g246 g699
+ (g231 'syntax
+ (cons g698
+ '0))
+ g691)
+ (g368 (list g697)
+ (list g699)
+ '(()))))
+ g693))
+ (g297)
+ (g451 g697))
+ (g611 g693
+ g690
+ (cdr g692)
+ g691
+ g697
+ '#t
+ g696)))
+ g695)
+ ((lambda (g700)
+ (if g700
+ (apply
+ (lambda (g703
+ g701
+ g702)
+ (g611 g693
+ g690
+ (cdr g692)
+ g691
+ g703
+ g701
+ g702))
+ g700)
+ ((lambda (g704)
+ (syntax-error
+ (car g692)
+ '"invalid syntax-case clause"))
+ g694)))
+ ($syntax-dispatch
+ g694
+ '(any any any)))))
+ ($syntax-dispatch
+ g694
+ '(any any))))
+ (car g692)))))
+ (g611
+ (lambda (g635 g629 g634 g630 g633 g631 g632)
+ (call-with-values
+ (lambda () (g609 g633 g629))
+ (lambda (g637 g636)
+ (if (not (g390 (map car g636)))
+ (g391 (map car g636)
+ g633
+ '"pattern variable")
+ (if (not (andmap
+ (lambda (g638)
+ (not (g447 (car g638))))
+ g636))
+ (syntax-error
+ g633
+ '"misplaced ellipsis in syntax-case pattern")
+ ((lambda (g639)
+ (list (list 'lambda
+ (list g639)
+ (list 'if
+ ((lambda (g649)
+ ((lambda (g650)
+ (if g650
+ (apply
+ (lambda ()
+ g639)
+ g650)
+ ((lambda (g651)
+ (list 'if
+ g639
+ (g610 g636
+ g631
+ g639
+ g630)
+ (list 'quote
+ '#f)))
+ g649)))
+ ($syntax-dispatch
+ g649
+ '#(atom
+ #t))))
+ g631)
+ (g610 g636
+ g632
+ g639
+ g630)
+ (g612 g635
+ g629
+ g634
+ g630)))
+ (if (eq? g637 'any)
+ (list 'list g635)
+ (list '$syntax-dispatch
+ g635
+ (list 'quote
+ g637)))))
+ (g451 'tmp))))))))
+ (g610
+ (lambda (g683 g680 g682 g681)
+ ((lambda (g685 g684)
+ ((lambda (g687 g686)
+ (list 'apply
+ (list 'lambda
+ g686
+ (g432 g680
+ (g247 g687
+ (map (lambda (g689
+ g688)
+ (g231 'syntax
+ (cons g689
+ g688)))
+ g686
+ (map cdr
+ g683))
+ g681)
+ (g368 g685
+ g687
+ '(()))))
+ g682))
+ (g299 g685)
+ (map g451 g685)))
+ (map car g683)
+ (map cdr g683))))
+ (g609
+ (lambda (g653 g652)
+ ((letrec ((g654
+ (lambda (g657 g655 g656)
+ (if (g256 g657)
+ (if (g392 g657 g652)
+ (values
+ (vector
+ 'free-id
+ g657)
+ g656)
+ (values
+ 'any
+ (cons (cons g657
+ g655)
+ g656)))
+ ((lambda (g658)
+ ((lambda (g659)
+ (if (if g659
+ (apply
+ (lambda (g661
+ g660)
+ (g447 g660))
+ g659)
+ '#f)
+ (apply
+ (lambda (g663
+ g662)
+ (call-with-values
+ (lambda ()
+ (g654 g663
+ (+ g655
+ '1)
+ g656))
+ (lambda (g665
+ g664)
+ (values
+ (if (eq? g665
+ 'any)
+ 'each-any
+ (vector
+ 'each
+ g665))
+ g664))))
+ g659)
+ ((lambda (g666)
+ (if g666
+ (apply
+ (lambda (g668
+ g667)
+ (call-with-values
+ (lambda ()
+ (g654 g667
+ g655
+ g656))
+ (lambda (g670
+ g669)
+ (call-with-values
+ (lambda ()
+ (g654 g668
+ g655
+ g669))
+ (lambda (g672
+ g671)
+ (values
+ (cons g672
+ g670)
+ g671))))))
+ g666)
+ ((lambda (g673)
+ (if g673
+ (apply
+ (lambda ()
+ (values
+ '()
+ g656))
+ g673)
+ ((lambda (g674)
+ (if g674
+ (apply
+ (lambda (g675)
+ (call-with-values
+ (lambda ()
+ (g654 g675
+ g655
+ g656))
+ (lambda (g677
+ g676)
+ (values
+ (vector
+ 'vector
+ g677)
+ g676))))
+ g674)
+ ((lambda (g679)
+ (values
+ (vector
+ 'atom
+ (g450 g657
+ '(())))
+ g656))
+ g658)))
+ ($syntax-dispatch
+ g658
+ '#(vector
+ each-any)))))
+ ($syntax-dispatch
+ g658
+ '()))))
+ ($syntax-dispatch
+ g658
+ '(any .
+ any)))))
+ ($syntax-dispatch
+ g658
+ '(any any))))
+ g657)))))
+ g654)
+ g653
+ '0
+ '()))))
+ (lambda (g616 g613 g615 g614)
+ ((lambda (g617)
+ ((lambda (g618)
+ ((lambda (g619)
+ (if g619
+ (apply
+ (lambda (g623 g620 g622 g621)
+ (if (andmap
+ (lambda (g625)
+ (if (g256 g625)
+ (not (g447 g625))
+ '#f))
+ g622)
+ ((lambda (g626)
+ (list (list 'lambda
+ (list g626)
+ (g612 g626
+ g622
+ g621
+ g613))
+ (g432 g620
+ g613
+ '(()))))
+ (g451 'tmp))
+ (syntax-error
+ g617
+ '"invalid literals list in")))
+ g619)
+ (syntax-error g618)))
+ ($syntax-dispatch
+ g618
+ '(any any each-any . each-any))))
+ g617))
+ (g394 g616 g615 g614)))))))
+ (set! sc-expand
+ ((lambda (g763 g761 g762)
+ ((lambda (g764)
+ (lambda (g765)
+ (if (if (pair? g765) (equal? (car g765) g53) '#f)
+ (cadr g765)
+ (g400 g765 '() g764 g763 g761 g762))))
+ (g263 (g264 '((top))) (cons g762 (g265 '((top)))))))
+ 'e
+ '(eval)
+ ((lambda (g766) (begin (g366 g766 '*top*) g766))
+ (g304 '() '() '()))))
+ (set! identifier? (lambda (g705) (g255 g705)))
+ (set! datum->syntax-object
+ (lambda (g759 g758)
+ (begin ((lambda (g760)
+ (if (not (g255 g760))
+ (g93 'datum->syntax-object
+ '"invalid argument"
+ g760)
+ (void)))
+ g759)
+ (g203 g758 (g206 g759)))))
+ (set! syntax-object->datum
+ (lambda (g706) (g450 g706 '(()))))
+ (set! generate-temporaries
+ (lambda (g755)
+ (begin ((lambda (g757)
+ (if (not (list? g757))
+ (g93 'generate-temporaries
+ '"invalid argument"
+ g757)
+ (void)))
+ g755)
+ (map (lambda (g756) (g393 (gensym) '((top))))
+ g755))))
+ (set! free-identifier=?
+ (lambda (g708 g707)
+ (begin ((lambda (g710)
+ (if (not (g255 g710))
+ (g93 'free-identifier=?
+ '"invalid argument"
+ g710)
+ (void)))
+ g708)
+ ((lambda (g709)
+ (if (not (g255 g709))
+ (g93 'free-identifier=?
+ '"invalid argument"
+ g709)
+ (void)))
+ g707)
+ (g378 g708 g707))))
+ (set! bound-identifier=?
+ (lambda (g752 g751)
+ (begin ((lambda (g754)
+ (if (not (g255 g754))
+ (g93 'bound-identifier=?
+ '"invalid argument"
+ g754)
+ (void)))
+ g752)
+ ((lambda (g753)
+ (if (not (g255 g753))
+ (g93 'bound-identifier=?
+ '"invalid argument"
+ g753)
+ (void)))
+ g751)
+ (g388 g752 g751))))
+ (set! syntax-error
+ (lambda (g711 . g712)
+ (begin (for-each
+ (lambda (g714)
+ ((lambda (g715)
+ (if (not (string? g715))
+ (g93 'syntax-error
+ '"invalid argument"
+ g715)
+ (void)))
+ g714))
+ g712)
+ ((lambda (g713) (g93 '#f g713 (g450 g711 '(()))))
+ (if (null? g712)
+ '"invalid syntax"
+ (apply string-append g712))))))
+ ((lambda ()
+ (letrec ((g720
+ (lambda (g748 g745 g747 g746)
+ (if (not g746)
+ '#f
+ (if (eq? g745 'any)
+ (cons (g393 g748 g747) g746)
+ (if (g204 g748)
+ (g719 ((lambda (g749)
+ (if (g90 g749)
+ (annotation-expression
+ g749)
+ g749))
+ (g205 g748))
+ g745
+ (g371 g747 (g206 g748))
+ g746)
+ (g719 ((lambda (g750)
+ (if (g90 g750)
+ (annotation-expression
+ g750)
+ g750))
+ g748)
+ g745
+ g747
+ g746))))))
+ (g719
+ (lambda (g728 g725 g727 g726)
+ (if (null? g725)
+ (if (null? g728) g726 '#f)
+ (if (pair? g725)
+ (if (pair? g728)
+ (g720 (car g728)
+ (car g725)
+ g727
+ (g720 (cdr g728)
+ (cdr g725)
+ g727
+ g726))
+ '#f)
+ (if (eq? g725 'each-any)
+ ((lambda (g729)
+ (if g729 (cons g729 g726) '#f))
+ (g717 g728 g727))
+ ((lambda (g730)
+ (if (memv g730 '(each))
+ (if (null? g728)
+ (g718 (vector-ref
+ g725
+ '1)
+ g726)
+ ((lambda (g731)
+ (if g731
+ ((letrec ((g732
+ (lambda (g733)
+ (if (null?
+ (car g733))
+ g726
+ (cons (map car
+ g733)
+ (g732 (map cdr
+ g733)))))))
+ g732)
+ g731)
+ '#f))
+ (g716 g728
+ (vector-ref
+ g725
+ '1)
+ g727)))
+ (if (memv g730 '(free-id))
+ (if (g256 g728)
+ (if (g378 (g393 g728
+ g727)
+ (vector-ref
+ g725
+ '1))
+ g726
+ '#f)
+ '#f)
+ (if (memv g730 '(atom))
+ (if (equal?
+ (vector-ref
+ g725
+ '1)
+ (g450 g728
+ g727))
+ g726
+ '#f)
+ (if (memv g730
+ '(vector))
+ (if (vector?
+ g728)
+ (g720 (vector->list
+ g728)
+ (vector-ref
+ g725
+ '1)
+ g727
+ g726)
+ '#f)
+ (void))))))
+ (vector-ref g725 '0)))))))
+ (g718
+ (lambda (g743 g742)
+ (if (null? g743)
+ g742
+ (if (eq? g743 'any)
+ (cons '() g742)
+ (if (pair? g743)
+ (g718 (car g743)
+ (g718 (cdr g743) g742))
+ (if (eq? g743 'each-any)
+ (cons '() g742)
+ ((lambda (g744)
+ (if (memv g744 '(each))
+ (g718 (vector-ref
+ g743
+ '1)
+ g742)
+ (if (memv g744
+ '(free-id
+ atom))
+ g742
+ (if (memv g744
+ '(vector))
+ (g718 (vector-ref
+ g743
+ '1)
+ g742)
+ (void)))))
+ (vector-ref g743 '0))))))))
+ (g717
+ (lambda (g735 g734)
+ (if (g90 g735)
+ (g717 (annotation-expression g735) g734)
+ (if (pair? g735)
+ ((lambda (g736)
+ (if g736
+ (cons (g393 (car g735) g734)
+ g736)
+ '#f))
+ (g717 (cdr g735) g734))
+ (if (null? g735)
+ '()
+ (if (g204 g735)
+ (g717 (g205 g735)
+ (g371 g734 (g206 g735)))
+ '#f))))))
+ (g716
+ (lambda (g739 g737 g738)
+ (if (g90 g739)
+ (g716 (annotation-expression g739)
+ g737
+ g738)
+ (if (pair? g739)
+ ((lambda (g740)
+ (if g740
+ ((lambda (g741)
+ (if g741
+ (cons g740 g741)
+ '#f))
+ (g716 (cdr g739) g737 g738))
+ '#f))
+ (g720 (car g739) g737 g738 '()))
+ (if (null? g739)
+ '()
+ (if (g204 g739)
+ (g716 (g205 g739)
+ g737
+ (g371 g738 (g206 g739)))
+ '#f)))))))
+ (set! $syntax-dispatch
+ (lambda (g722 g721)
+ (if (eq? g721 'any)
+ (list g722)
+ (if (g204 g722)
+ (g719 ((lambda (g723)
+ (if (g90 g723)
+ (annotation-expression g723)
+ g723))
+ (g205 g722))
+ g721
+ (g206 g722)
+ '())
+ (g719 ((lambda (g724)
+ (if (g90 g724)
+ (annotation-expression g724)
+ g724))
+ g722)
+ g721
+ '(())
+ '()))))))))))))
+($sc-put-cte
+ 'with-syntax
+ (lambda (g1828)
+ ((lambda (g1829)
+ ((lambda (g1830)
+ (if g1830
+ (apply
+ (lambda (g1833 g1831 g1832)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ e1 e2)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ (cons g1831 g1832)))
+ g1830)
+ ((lambda (g1835)
+ (if g1835
+ (apply
+ (lambda (g1840 g1836 g1839 g1837 g1838)
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g1839
+ '()
+ (list g1836
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g1837 g1838)))))
+ g1835)
+ ((lambda (g1842)
+ (if g1842
+ (apply
+ (lambda (g1847 g1843 g1846 g1844 g1845)
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g1846)
+ '()
+ (list g1843
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1844 g1845)))))
+ g1842)
+ (syntax-error g1829)))
+ ($syntax-dispatch
+ g1829
+ '(any #(each (any any)) any . each-any)))))
+ ($syntax-dispatch
+ g1829
+ '(any ((any any)) any . each-any)))))
+ ($syntax-dispatch g1829 '(any () any . each-any))))
+ g1828)))
+($sc-put-cte
+ 'syntax-rules
+ (lambda (g1851)
+ ((lambda (g1852)
+ ((lambda (g1853)
+ (if g1853
+ (apply
+ (lambda (g1858 g1854 g1857 g1855 g1856)
+ (list '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ (cons '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g1854
+ (map (lambda (g1861 g1860)
+ (list (cons '#(syntax-object
+ dummy
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1860)
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1861)))
+ g1856
+ g1855))))))
+ g1853)
+ (syntax-error g1852)))
+ ($syntax-dispatch
+ g1852
+ '(any each-any . #(each ((any . any) any))))))
+ g1851)))
+($sc-put-cte
+ 'or
+ (lambda (g1862)
+ ((lambda (g1863)
+ ((lambda (g1864)
+ (if g1864
+ (apply
+ (lambda (g1865)
+ '#(syntax-object
+ #f
+ ((top)
+ #(ribcage #(_) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ g1864)
+ ((lambda (g1866)
+ (if g1866
+ (apply (lambda (g1868 g1867) g1867) g1866)
+ ((lambda (g1869)
+ (if g1869
+ (apply
+ (lambda (g1873 g1870 g1872 g1871)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1870))
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons '#(syntax-object
+ or
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1872 g1871)))))
+ g1869)
+ (syntax-error g1863)))
+ ($syntax-dispatch g1863 '(any any any . each-any)))))
+ ($syntax-dispatch g1863 '(any any)))))
+ ($syntax-dispatch g1863 '(any))))
+ g1862)))
+($sc-put-cte
+ 'and
+ (lambda (g1875)
+ ((lambda (g1876)
+ ((lambda (g1877)
+ (if g1877
+ (apply
+ (lambda (g1881 g1878 g1880 g1879)
+ (cons '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ (cons g1878
+ (cons (cons '#(syntax-object
+ and
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g1880 g1879))
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(_ e1 e2 e3)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))))))
+ g1877)
+ ((lambda (g1883)
+ (if g1883
+ (apply (lambda (g1885 g1884) g1884) g1883)
+ ((lambda (g1886)
+ (if g1886
+ (apply
+ (lambda (g1887)
+ '#(syntax-object
+ #t
+ ((top)
+ #(ribcage #(_) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ g1886)
+ (syntax-error g1876)))
+ ($syntax-dispatch g1876 '(any)))))
+ ($syntax-dispatch g1876 '(any any)))))
+ ($syntax-dispatch g1876 '(any any any . each-any))))
+ g1875)))
+($sc-put-cte
+ 'let
+ (lambda (g1888)
+ ((lambda (g1889)
+ ((lambda (g1890)
+ (if (if g1890
+ (apply
+ (lambda (g1895 g1891 g1894 g1892 g1893)
+ (andmap identifier? g1891))
+ g1890)
+ '#f)
+ (apply
+ (lambda (g1901 g1897 g1900 g1898 g1899)
+ (cons (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ x v e1 e2)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g1897 (cons g1898 g1899)))
+ g1900))
+ g1890)
+ ((lambda (g1905)
+ (if (if g1905
+ (apply
+ (lambda (g1911 g1906 g1910 g1907 g1909 g1908)
+ (andmap identifier? (cons g1906 g1910)))
+ g1905)
+ '#f)
+ (apply
+ (lambda (g1918 g1913 g1917 g1914 g1916 g1915)
+ (cons (list '#(syntax-object
+ letrec
+ ((top)
+ #(ribcage
+ #(_ f x v e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (list (list g1913
+ (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_
+ f
+ x
+ v
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1917
+ (cons g1916
+ g1915)))))
+ g1913)
+ g1914))
+ g1905)
+ (syntax-error g1889)))
+ ($syntax-dispatch
+ g1889
+ '(any any #(each (any any)) any . each-any)))))
+ ($syntax-dispatch
+ g1889
+ '(any #(each (any any)) any . each-any))))
+ g1888)))
+($sc-put-cte
+ 'let*
+ (lambda (g1922)
+ ((lambda (g1923)
+ ((lambda (g1924)
+ (if (if g1924
+ (apply
+ (lambda (g1929 g1925 g1928 g1926 g1927)
+ (andmap identifier? g1925))
+ g1924)
+ '#f)
+ (apply
+ (lambda (g1935 g1931 g1934 g1932 g1933)
+ ((letrec ((g1936
+ (lambda (g1937)
+ (if (null? g1937)
+ (cons '#(syntax-object
+ let
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(bindings)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(let* x v e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons '() (cons g1932 g1933)))
+ ((lambda (g1939)
+ ((lambda (g1940)
+ (if g1940
+ (apply
+ (lambda (g1942 g1941)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(body
+ binding)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(bindings)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(let*
+ x
+ v
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list g1941)
+ g1942))
+ g1940)
+ (syntax-error g1939)))
+ ($syntax-dispatch
+ g1939
+ '(any any))))
+ (list (g1936 (cdr g1937))
+ (car g1937)))))))
+ g1936)
+ (map list g1931 g1934)))
+ g1924)
+ (syntax-error g1923)))
+ ($syntax-dispatch
+ g1923
+ '(any #(each (any any)) any . each-any))))
+ g1922)))
+($sc-put-cte
+ 'cond
+ (lambda (g1945)
+ ((lambda (g1946)
+ ((lambda (g1947)
+ (if g1947
+ (apply
+ (lambda (g1950 g1948 g1949)
+ ((letrec ((g1951
+ (lambda (g1953 g1952)
+ (if (null? g1952)
+ ((lambda (g1954)
+ ((lambda (g1955)
+ (if g1955
+ (apply
+ (lambda (g1957 g1956)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ m1 m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1957 g1956)))
+ g1955)
+ ((lambda (g1959)
+ (if g1959
+ (apply
+ (lambda (g1960)
+ (cons '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1960))
+ '((#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))))))
+ g1959)
+ ((lambda (g1961)
+ (if g1961
+ (apply
+ (lambda (g1963
+ g1962)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1963))
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1962
+ '(#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))))))
+ g1961)
+ ((lambda (g1964)
+ (if g1964
+ (apply
+ (lambda (g1967
+ g1965
+ g1966)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1967
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e0
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1965
+ g1966))))
+ g1964)
+ ((lambda (g1969)
+ (syntax-error
+ g1945))
+ g1954)))
+ ($syntax-dispatch
+ g1954
+ '(any any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ g1954
+ '(any #(free-id
+ #(syntax-object
+ =>
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ any)))))
+ ($syntax-dispatch
+ g1954
+ '(any)))))
+ ($syntax-dispatch
+ g1954
+ '(#(free-id
+ #(syntax-object
+ else
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(clause clauses)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ m1 m2)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ any
+ .
+ each-any))))
+ g1953)
+ ((lambda (g1970)
+ ((lambda (g1971)
+ ((lambda (g1972)
+ ((lambda (g1973)
+ (if g1973
+ (apply
+ (lambda (g1974)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1974))
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1971)))
+ g1973)
+ ((lambda (g1975)
+ (if g1975
+ (apply
+ (lambda (g1977
+ g1976)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1977))
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1976
+ '(#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(e0
+ e1)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))))
+ g1971)))
+ g1975)
+ ((lambda (g1978)
+ (if g1978
+ (apply
+ (lambda (g1981
+ g1979
+ g1980)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e0
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1981
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e0
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g1979
+ g1980))
+ g1971))
+ g1978)
+ ((lambda (g1983)
+ (syntax-error
+ g1945))
+ g1972)))
+ ($syntax-dispatch
+ g1972
+ '(any any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ g1972
+ '(any #(free-id
+ #(syntax-object
+ =>
+ ((top)
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ m1
+ m2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ any)))))
+ ($syntax-dispatch
+ g1972
+ '(any))))
+ g1953))
+ g1970))
+ (g1951 (car g1952) (cdr g1952)))))))
+ g1951)
+ g1948
+ g1949))
+ g1947)
+ (syntax-error g1946)))
+ ($syntax-dispatch g1946 '(any any . each-any))))
+ g1945)))
+($sc-put-cte
+ 'do
+ (lambda (g1985)
+ ((lambda (g1986)
+ ((lambda (g1987)
+ (if g1987
+ (apply
+ (lambda (g1994 g1988 g1993 g1989 g1992 g1990 g1991)
+ ((lambda (g1995)
+ ((lambda (g2005)
+ (if g2005
+ (apply
+ (lambda (g2006)
+ ((lambda (g2007)
+ ((lambda (g2009)
+ (if g2009
+ (apply
+ (lambda ()
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (map list g1988 g1993)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ not
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1992)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (append
+ g1991
+ (list (cons '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2006)))))))
+ g2009)
+ ((lambda (g2014)
+ (if g2014
+ (apply
+ (lambda (g2016 g2015)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (map list
+ g1988
+ g1993)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g1992
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2016
+ g2015))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (append
+ g1991
+ (list (cons '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2006)))))))
+ g2014)
+ (syntax-error g2007)))
+ ($syntax-dispatch
+ g2007
+ '(any . each-any)))))
+ ($syntax-dispatch g2007 '())))
+ g1990))
+ g2005)
+ (syntax-error g1995)))
+ ($syntax-dispatch g1995 'each-any)))
+ (map (lambda (g1999 g1998)
+ ((lambda (g2000)
+ ((lambda (g2001)
+ (if g2001
+ (apply (lambda () g1999) g2001)
+ ((lambda (g2002)
+ (if g2002
+ (apply
+ (lambda (g2003) g2003)
+ g2002)
+ ((lambda (g2004)
+ (syntax-error g1985))
+ g2000)))
+ ($syntax-dispatch g2000 '(any)))))
+ ($syntax-dispatch g2000 '())))
+ g1998))
+ g1988
+ g1989)))
+ g1987)
+ (syntax-error g1986)))
+ ($syntax-dispatch
+ g1986
+ '(any #(each (any any . any))
+ (any . each-any)
+ .
+ each-any))))
+ g1985)))
+($sc-put-cte
+ 'quasiquote
+ (letrec ((g2030
+ (lambda (g2142)
+ (if (identifier? g2142)
+ (free-identifier=?
+ g2142
+ '#(syntax-object
+ quote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ '#f)))
+ (g2022
+ (lambda (g2036)
+ (if (identifier? g2036)
+ (free-identifier=?
+ g2036
+ '#(syntax-object
+ list
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ '#f)))
+ (g2029
+ (lambda (g2141)
+ (if (identifier? g2141)
+ (free-identifier=?
+ g2141
+ '#(syntax-object
+ cons
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ '#f)))
+ (g2023
+ (lambda (g2037)
+ ((lambda (g2038)
+ ((lambda (g2039)
+ (if g2039
+ (apply (lambda (g2040) (g2030 g2040)) g2039)
+ ((lambda (g2041) '#f) g2038)))
+ ($syntax-dispatch g2038 '(any ()))))
+ g2037)))
+ (g2028
+ (lambda (g2138 g2137)
+ ((letrec ((g2139
+ (lambda (g2140)
+ (if (null? g2140)
+ g2137
+ (g2024 (car g2140) (g2139 (cdr g2140)))))))
+ g2139)
+ g2138)))
+ (g2024
+ (lambda (g2043 g2042)
+ ((lambda (g2044)
+ ((lambda (g2045)
+ (if g2045
+ (apply
+ (lambda (g2047 g2046)
+ ((lambda (g2048)
+ ((lambda (g2049)
+ (if (if g2049
+ (apply
+ (lambda (g2051 g2050)
+ (g2030 g2051))
+ g2049)
+ '#f)
+ (apply
+ (lambda (g2053 g2052)
+ ((lambda (g2054)
+ ((lambda (g2055)
+ (if (if g2055
+ (apply
+ (lambda (g2057
+ g2056)
+ (g2030 g2057))
+ g2055)
+ '#f)
+ (apply
+ (lambda (g2059 g2058)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(quote?
+ dx)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(quote?
+ dy)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(x y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2058
+ g2052)))
+ g2055)
+ ((lambda (g2060)
+ (if (null? g2052)
+ (list '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(quote?
+ dy)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2047)
+ (list '#(syntax-object
+ cons
+ ((top)
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(quote?
+ dy)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ y)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2047
+ g2046)))
+ g2054)))
+ ($syntax-dispatch
+ g2054
+ '(any any))))
+ g2047))
+ g2049)
+ ((lambda (g2061)
+ (if (if g2061
+ (apply
+ (lambda (g2063 g2062)
+ (g2022 g2063))
+ g2061)
+ '#f)
+ (apply
+ (lambda (g2065 g2064)
+ (cons '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(listp stuff)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2047 g2064)))
+ g2061)
+ ((lambda (g2066)
+ (list '#(syntax-object
+ cons
+ ((top)
+ #(ribcage
+ #(else)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2047
+ g2046))
+ g2048)))
+ ($syntax-dispatch
+ g2048
+ '(any . any)))))
+ ($syntax-dispatch g2048 '(any any))))
+ g2046))
+ g2045)
+ (syntax-error g2044)))
+ ($syntax-dispatch g2044 '(any any))))
+ (list g2043 g2042))))
+ (g2027
+ (lambda (g2129 g2128)
+ ((lambda (g2130)
+ (if (null? g2130)
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(ls) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x y) #((top) (top)) #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ ())
+ (if (null? (cdr g2130))
+ (car g2130)
+ ((lambda (g2131)
+ ((lambda (g2132)
+ (if g2132
+ (apply
+ (lambda (g2133)
+ (cons '#(syntax-object
+ append
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(ls)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2133))
+ g2132)
+ (syntax-error g2131)))
+ ($syntax-dispatch g2131 'each-any)))
+ g2130))))
+ ((letrec ((g2135
+ (lambda (g2136)
+ (if (null? g2136)
+ (if (g2023 g2128) '() (list g2128))
+ (if (g2023 (car g2136))
+ (g2135 (cdr g2136))
+ (cons (car g2136)
+ (g2135 (cdr g2136))))))))
+ g2135)
+ g2129))))
+ (g2025
+ (lambda (g2067)
+ ((lambda (g2068)
+ ((lambda (g2069)
+ ((lambda (g2070)
+ ((lambda (g2071)
+ (if (if g2071
+ (apply
+ (lambda (g2073 g2072) (g2030 g2073))
+ g2071)
+ '#f)
+ (apply
+ (lambda (g2075 g2074)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(quote? x)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(pat-x)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (list->vector g2074)))
+ g2071)
+ ((lambda (g2077)
+ ((letrec ((g2078
+ (lambda (g2080 g2079)
+ ((lambda (g2081)
+ ((lambda (g2082)
+ (if (if g2082
+ (apply
+ (lambda (g2084
+ g2083)
+ (g2030
+ g2084))
+ g2082)
+ '#f)
+ (apply
+ (lambda (g2086
+ g2085)
+ (g2079
+ (map (lambda (g2087)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(quote?
+ x)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ k)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(pat-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2087))
+ g2085)))
+ g2082)
+ ((lambda (g2088)
+ (if (if g2088
+ (apply
+ (lambda (g2090
+ g2089)
+ (g2022
+ g2090))
+ g2088)
+ '#f)
+ (apply
+ (lambda (g2092
+ g2091)
+ (g2079
+ g2091))
+ g2088)
+ ((lambda (g2094)
+ (if (if g2094
+ (apply
+ (lambda (g2097
+ g2095
+ g2096)
+ (g2029
+ g2097))
+ g2094)
+ '#f)
+ (apply
+ (lambda (g2100
+ g2098
+ g2099)
+ (g2078
+ g2099
+ (lambda (g2101)
+ (g2079
+ (cons g2098
+ g2101)))))
+ g2094)
+ ((lambda (g2102)
+ (list '#(syntax-object
+ list->vector
+ ((top)
+ #(ribcage
+ #(else)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x
+ k)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(pat-x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2069))
+ g2081)))
+ ($syntax-dispatch
+ g2081
+ '(any any
+ any)))))
+ ($syntax-dispatch
+ g2081
+ '(any .
+ each-any)))))
+ ($syntax-dispatch
+ g2081
+ '(any each-any))))
+ g2080))))
+ g2078)
+ g2067
+ (lambda (g2103)
+ (cons '#(syntax-object
+ vector
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(ls)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(pat-x)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2103))))
+ g2070)))
+ ($syntax-dispatch g2070 '(any each-any))))
+ g2069))
+ g2068))
+ g2067)))
+ (g2026
+ (lambda (g2105 g2104)
+ ((lambda (g2106)
+ ((lambda (g2107)
+ (if g2107
+ (apply
+ (lambda (g2108)
+ (if (= g2104 '0)
+ g2108
+ (g2024
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage #(p) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage #(p) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (g2026 (list g2108) (- g2104 '1)))))
+ g2107)
+ ((lambda (g2109)
+ (if g2109
+ (apply
+ (lambda (g2111 g2110)
+ (if (= g2104 '0)
+ (g2028 g2111 (g2026 g2110 g2104))
+ (g2024
+ (g2024
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p q)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage
+ #(p q)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (g2026 g2111 (- g2104 '1)))
+ (g2026 g2110 g2104))))
+ g2109)
+ ((lambda (g2114)
+ (if g2114
+ (apply
+ (lambda (g2116 g2115)
+ (if (= g2104 '0)
+ (g2027
+ g2116
+ (g2026 g2115 g2104))
+ (g2024
+ (g2024
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p q)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ unquote-splicing
+ ((top)
+ #(ribcage
+ #(p q)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ (g2026
+ g2116
+ (- g2104 '1)))
+ (g2026 g2115 g2104))))
+ g2114)
+ ((lambda (g2119)
+ (if g2119
+ (apply
+ (lambda (g2120)
+ (g2024
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))
+ (g2026
+ (list g2120)
+ (+ g2104 '1))))
+ g2119)
+ ((lambda (g2121)
+ (if g2121
+ (apply
+ (lambda (g2123 g2122)
+ (g2024
+ (g2026
+ g2123
+ g2104)
+ (g2026
+ g2122
+ g2104)))
+ g2121)
+ ((lambda (g2124)
+ (if g2124
+ (apply
+ (lambda (g2125)
+ (g2025
+ (g2026
+ g2125
+ g2104)))
+ g2124)
+ ((lambda (g2127)
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(p)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(p
+ lev)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2127))
+ g2106)))
+ ($syntax-dispatch
+ g2106
+ '#(vector
+ each-any)))))
+ ($syntax-dispatch
+ g2106
+ '(any . any)))))
+ ($syntax-dispatch
+ g2106
+ '(#(free-id
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ any)))))
+ ($syntax-dispatch
+ g2106
+ '((#(free-id
+ #(syntax-object
+ unquote-splicing
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ .
+ each-any)
+ .
+ any)))))
+ ($syntax-dispatch
+ g2106
+ '((#(free-id
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p lev)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ .
+ each-any)
+ .
+ any)))))
+ ($syntax-dispatch
+ g2106
+ '(#(free-id
+ #(syntax-object
+ unquote
+ ((top)
+ #(ribcage () () ())
+ #(ribcage #(p lev) #((top) (top)) #("i" "i"))
+ #(ribcage
+ #(isquote?
+ islist?
+ iscons?
+ quote-nil?
+ quasilist*
+ quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ any))))
+ g2105))))
+ (lambda (g2031)
+ ((lambda (g2032)
+ ((lambda (g2033)
+ (if g2033
+ (apply (lambda (g2035 g2034) (g2026 g2034 '0)) g2033)
+ (syntax-error g2032)))
+ ($syntax-dispatch g2032 '(any any))))
+ g2031))))
+($sc-put-cte
+ 'include
+ (lambda (g2143)
+ (letrec ((g2144
+ (lambda (g2155 g2154)
+ ((lambda (g2156)
+ ((letrec ((g2157
+ (lambda ()
+ ((lambda (g2158)
+ (if (eof-object? g2158)
+ (begin (close-input-port g2156) '())
+ (cons (datum->syntax-object
+ g2154
+ g2158)
+ (g2157))))
+ (read g2156)))))
+ g2157)))
+ (open-input-file g2155)))))
+ ((lambda (g2145)
+ ((lambda (g2146)
+ (if g2146
+ (apply
+ (lambda (g2148 g2147)
+ ((lambda (g2149)
+ ((lambda (g2150)
+ ((lambda (g2151)
+ (if g2151
+ (apply
+ (lambda (g2152)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(exp)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(fn)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(k filename)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ (read-file)
+ ((top))
+ ("i"))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2152))
+ g2151)
+ (syntax-error g2150)))
+ ($syntax-dispatch g2150 'each-any)))
+ (g2144 g2149 g2148)))
+ (syntax-object->datum g2147)))
+ g2146)
+ (syntax-error g2145)))
+ ($syntax-dispatch g2145 '(any any))))
+ g2143))))
+($sc-put-cte
+ 'unquote
+ (lambda (g2159)
+ ((lambda (g2160)
+ ((lambda (g2161)
+ (if g2161
+ (apply
+ (lambda (g2163 g2162)
+ (syntax-error
+ g2159
+ '"expression not valid outside of quasiquote"))
+ g2161)
+ (syntax-error g2160)))
+ ($syntax-dispatch g2160 '(any . each-any))))
+ g2159)))
+($sc-put-cte
+ 'unquote-splicing
+ (lambda (g2164)
+ ((lambda (g2165)
+ ((lambda (g2166)
+ (if g2166
+ (apply
+ (lambda (g2168 g2167)
+ (syntax-error
+ g2164
+ '"expression not valid outside of quasiquote"))
+ g2166)
+ (syntax-error g2165)))
+ ($syntax-dispatch g2165 '(any . each-any))))
+ g2164)))
+($sc-put-cte
+ 'case
+ (lambda (g2169)
+ ((lambda (g2170)
+ ((lambda (g2171)
+ (if g2171
+ (apply
+ (lambda (g2175 g2172 g2174 g2173)
+ ((lambda (g2176)
+ ((lambda (g2203)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage #(body) #((top)) #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(body)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2172))
+ g2203))
+ g2176))
+ ((letrec ((g2177
+ (lambda (g2179 g2178)
+ (if (null? g2178)
+ ((lambda (g2180)
+ ((lambda (g2181)
+ (if g2181
+ (apply
+ (lambda (g2183 g2182)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2183
+ g2182)))
+ g2181)
+ ((lambda (g2185)
+ (if g2185
+ (apply
+ (lambda (g2188
+ g2186
+ g2187)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ memv
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2188))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2186
+ g2187))))
+ g2185)
+ ((lambda (g2191)
+ (syntax-error
+ g2169))
+ g2180)))
+ ($syntax-dispatch
+ g2180
+ '(each-any
+ any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ g2180
+ '(#(free-id
+ #(syntax-object
+ else
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(clause clauses)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ any
+ .
+ each-any))))
+ g2179)
+ ((lambda (g2192)
+ ((lambda (g2193)
+ ((lambda (g2194)
+ ((lambda (g2195)
+ (if g2195
+ (apply
+ (lambda (g2198
+ g2196
+ g2197)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ memv
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2198))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(clause
+ clauses)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(f)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2196
+ g2197))
+ g2193))
+ g2195)
+ ((lambda (g2201)
+ (syntax-error
+ g2169))
+ g2194)))
+ ($syntax-dispatch
+ g2194
+ '(each-any
+ any
+ .
+ each-any))))
+ g2179))
+ g2192))
+ (g2177 (car g2178) (cdr g2178)))))))
+ g2177)
+ g2174
+ g2173)))
+ g2171)
+ (syntax-error g2170)))
+ ($syntax-dispatch g2170 '(any any any . each-any))))
+ g2169)))
+($sc-put-cte
+ 'identifier-syntax
+ (lambda (g2204)
+ ((lambda (g2205)
+ ((lambda (g2206)
+ (if g2206
+ (apply
+ (lambda (g2208 g2207)
+ (list '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage #(_ e) #((top) (top)) #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ())))
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage #(_ e) #((top) (top)) #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '()
+ (list '#(syntax-object
+ id
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '(#(syntax-object
+ identifier?
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ id
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ g2207))
+ (list (cons g2208
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ (cons g2207
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ()))))))))))
+ g2206)
+ ((lambda (g2209)
+ (if (if g2209
+ (apply
+ (lambda (g2215 g2210 g2214 g2211 g2213 g2212)
+ (if (identifier? g2210)
+ (identifier? g2211)
+ '#f))
+ g2209)
+ '#f)
+ (apply
+ (lambda (g2221 g2216 g2220 g2217 g2219 g2218)
+ (list '#(syntax-object
+ cons
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top) (top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '(#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ #(syntax-object
+ macro!
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (list '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ())))
+ '(#(syntax-object
+ set!
+ ((top)
+ #(ribcage
+ #(_ id exp1 var val exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token . *top*))
+ ()
+ ()))))
+ (list (list '#(syntax-object
+ set!
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2217
+ g2219)
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2218))
+ (list (cons g2216
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (cons g2220
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ #(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))))))
+ (list g2216
+ (list '#(syntax-object
+ identifier?
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2216))
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ id
+ exp1
+ var
+ val
+ exp2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ((import-token
+ .
+ *top*))
+ ()
+ ())))
+ g2220))))))
+ g2209)
+ (syntax-error g2205)))
+ ($syntax-dispatch
+ g2205
+ '(any (any any)
+ ((#(free-id
+ #(syntax-object
+ set!
+ ((top)
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage ((import-token . *top*)) () ()))))
+ any
+ any)
+ any))))))
+ ($syntax-dispatch g2205 '(any any))))
+ g2204)))
--- /dev/null
+;;; Portable implementation of syntax-case
+;;; Extracted from Chez Scheme Version 6.3
+;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+
+;;; Copyright (c) 1992-2000 Cadence Research Systems
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright notice in full. This software
+;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
+;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
+;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
+;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
+;;; NATURE WHATSOEVER.
+
+;;; Before attempting to port this code to a new implementation of
+;;; Scheme, please read the notes below carefully.
+
+;;; This file defines the syntax-case expander, sc-expand, and a set
+;;; of associated syntactic forms and procedures. Of these, the
+;;; following are documented in The Scheme Programming Language,
+;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996), which can be
+;;; found online at http://www.scheme.com. Most are also documented
+;;; in the R4RS and draft R5RS.
+;;;
+;;; bound-identifier=?
+;;; datum->syntax-object
+;;; define-syntax
+;;; fluid-let-syntax
+;;; free-identifier=?
+;;; generate-temporaries
+;;; identifier?
+;;; identifier-syntax
+;;; let-syntax
+;;; letrec-syntax
+;;; syntax
+;;; syntax-case
+;;; syntax-object->datum
+;;; syntax-rules
+;;; with-syntax
+;;;
+;;; All standard Scheme syntactic forms are supported by the expander
+;;; or syntactic abstractions defined in this file. Only the R4RS
+;;; delay is omitted, since its expansion is implementation-dependent.
+
+;;; Also defined are three forms that support modules: module, import,
+;;; and import-only. These are documented in the Chez Scheme User's
+;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
+;;; also be found online at http://www.scheme.com. They are described
+;;; briefly here as well.
+;;;
+;;; Both are definitions and may appear where and only where other
+;;; definitions may appear. modules may be named:
+;;;
+;;; (module id (ex ...) defn ... init ...)
+;;;
+;;; or anonymous:
+;;;
+;;; (module (ex ...) defn ... init ...)
+;;;
+;;; The latter form is semantically equivalent to:
+;;;
+;;; (module T (ex ...) defn ... init ...)
+;;; (import T)
+;;;
+;;; where T is a fresh identifier.
+;;;
+;;; In either form, each of the exports in (ex ...) is either an
+;;; identifier or of the form (id ex ...). In the former case, the
+;;; single identifier ex is exported. In the latter, the identifier
+;;; id is exported and the exports ex ... are "implicitly" exported.
+;;; This listing of implicit exports is useful only when id is a
+;;; keyword bound to a transformer that expands into references to
+;;; the listed implicit exports. In the present implementation,
+;;; listing of implicit exports is necessary only for top-level
+;;; modules and allows the implementation to avoid placing all
+;;; identifiers into the top-level environment where subsequent passes
+;;; of the compiler will be unable to deal effectively with them.
+;;;
+;;; Named modules may be referenced in import statements, which
+;;; always take one of the forms:
+;;;
+;;; (import id)
+;;; (import-only id)
+;;;
+;;; id must name a module. Each exported identifier becomes visible
+;;; within the scope of the import form. In the case of import-only,
+;;; all other identifiers become invisible in the scope of the
+;;; import-only form, except for those established by definitions
+;;; that appear textually after the import-only form.
+
+;;; The remaining exports are listed below. sc-expand, eval-when, and
+;;; syntax-error are described in the Chez Scheme User's Guide.
+;;;
+;;; (sc-expand datum)
+;;; if datum represents a valid expression, sc-expand returns an
+;;; expanded version of datum in a core language that includes no
+;;; syntactic abstractions. The core language includes begin,
+;;; define, if, lambda, letrec, quote, and set!.
+;;; (eval-when situations expr ...)
+;;; conditionally evaluates expr ... at compile-time or run-time
+;;; depending upon situations
+;;; (syntax-error object message)
+;;; used to report errors found during expansion
+;;; ($syntax-dispatch e p)
+;;; used by expanded code to handle syntax-case matching
+;;; ($sc-put-cte symbol val)
+;;; used to establish top-level compile-time (expand-time) bindings.
+
+;;; The following nonstandard procedures must be provided by the
+;;; implementation for this code to run.
+;;;
+;;; (void)
+;;; returns the implementation's cannonical "unspecified value". The
+;;; following usually works:
+;;;
+;;; (define void (lambda () (if #f #f))).
+;;;
+;;; (andmap proc list1 list2 ...)
+;;; returns true if proc returns true when applied to each element of list1
+;;; along with the corresponding elements of list2 .... The following
+;;; definition works but does no error checking:
+;;;
+;;; (define andmap
+;;; (lambda (f first . rest)
+;;; (or (null? first)
+;;; (if (null? rest)
+;;; (let andmap ((first first))
+;;; (let ((x (car first)) (first (cdr first)))
+;;; (if (null? first)
+;;; (f x)
+;;; (and (f x) (andmap first)))))
+;;; (let andmap ((first first) (rest rest))
+;;; (let ((x (car first))
+;;; (xr (map car rest))
+;;; (first (cdr first))
+;;; (rest (map cdr rest)))
+;;; (if (null? first)
+;;; (apply f (cons x xr))
+;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
+;;;
+;;; (ormap proc list1)
+;;; returns the first non-false return result of proc applied to
+;;; the elements of list1 or false if none. The following definition
+;;; works but does no error checking:
+;;;
+;;; (define ormap
+;;; (lambda (proc list1)
+;;; (and (not (null? list1))
+;;; (or (proc (car list1)) (ormap proc (cdr list1))))))
+;;;
+;;; The following nonstandard procedures must also be provided by the
+;;; implementation for this code to run using the standard portable
+;;; hooks and output constructors. They are not used by expanded code,
+;;; and so need be present only at expansion time.
+;;;
+;;; (eval x)
+;;; where x is always in the form ("noexpand" expr).
+;;; returns the value of expr. the "noexpand" flag is used to tell the
+;;; evaluator/expander that no expansion is necessary, since expr has
+;;; already been fully expanded to core forms.
+;;;
+;;; eval will not be invoked during the loading of psyntax.pp. After
+;;; psyntax.pp has been loaded, the expansion of any macro definition,
+;;; whether local or global, results in a call to eval. If, however,
+;;; sc-expand has already been registered as the expander to be used
+;;; by eval, and eval accepts one argument, nothing special must be done
+;;; to support the "noexpand" flag, since it is handled by sc-expand.
+;;;
+;;; (error who format-string why what)
+;;; where who is either a symbol or #f, format-string is always "~a ~s",
+;;; why is always a string, and what may be any object. error should
+;;; signal an error with a message something like
+;;;
+;;; "error in <who>: <why> <what>"
+;;;
+;;; (gensym)
+;;; returns a unique symbol each time it's called. In Chez Scheme, gensym
+;;; returns a symbol with a "globally" unique name so that gensyms that
+;;; end up in the object code of separately compiled files cannot conflict.
+;;; This is necessary only if you intend to support compiled files.
+;;;
+;;; (putprop symbol key value)
+;;; (getprop symbol key)
+;;; (remprop symbol key)
+;;; key is always a symbol; value may be any object. putprop should
+;;; associate the given value with the given symbol and key in some way
+;;; that it can be retrieved later with getprop. getprop should return
+;;; #f if no value is associated with the given symbol and key. remprop
+;;; should remove the association between the given symbol and key.
+
+;;; When porting to a new Scheme implementation, you should define the
+;;; procedures listed above, load the expanded version of psyntax.ss
+;;; (psyntax.pp, which should be available whereever you found
+;;; psyntax.ss), and register sc-expand as the current expander (how
+;;; you do this depends upon your implementation of Scheme). You may
+;;; change the hooks and constructors defined toward the beginning of
+;;; the code below, but to avoid bootstrapping problems, do so only
+;;; after you have a working version of the expander.
+
+;;; Chez Scheme allows the syntactic form (syntax <template>) to be
+;;; abbreviated to #'<template>, just as (quote <datum>) may be
+;;; abbreviated to '<datum>. The #' syntax makes programs written
+;;; using syntax-case shorter and more readable and draws out the
+;;; intuitive connection between syntax and quote. If you have access
+;;; to the source code of your Scheme system's reader, you might want
+;;; to implement this extension.
+
+;;; If you find that this code loads or runs slowly, consider
+;;; switching to faster hardware or a faster implementation of
+;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
+;;; compiling (with full optimization), and loading this file takes
+;;; between one and two seconds.
+
+;;; In the expander implementation, we sometimes use syntactic abstractions
+;;; when procedural abstractions would suffice. For example, we define
+;;; top-wrap and top-marked? as
+;;; (define-syntax top-wrap (identifier-syntax '((top))))
+;;; (define-syntax top-marked?
+;;; (syntax-rules ()
+;;; ((_ w) (memq 'top (wrap-marks w)))))
+;;; rather than
+;;; (define top-wrap '((top)))
+;;; (define top-marked?
+;;; (lambda (w) (memq 'top (wrap-marks w))))
+;;; On ther other hand, we don't do this consistently; we define make-wrap,
+;;; wrap-marks, and wrap-subst simply as
+;;; (define make-wrap cons)
+;;; (define wrap-marks car)
+;;; (define wrap-subst cdr)
+;;; In Chez Scheme, the syntactic and procedural forms of these
+;;; abstractions are equivalent, since the optimizer consistently
+;;; integrates constants and small procedures. Some Scheme
+;;; implementations, however, may benefit from more consistent use
+;;; of one form or the other.
+
+
+;;; Implementation notes:
+
+;;; "begin" is treated as a splicing construct at top level and at
+;;; the beginning of bodies. Any sequence of expressions that would
+;;; be allowed where the "begin" occurs is allowed.
+
+;;; "let-syntax" and "letrec-syntax" are also treated as splicing
+;;; constructs, in violation of the R5RS. A consequence is that let-syntax
+;;; and letrec-syntax do not create local contours, as do let and letrec.
+;;; Although the functionality is greater as it is presently implemented,
+;;; we will probably change it to conform to the R5RS. modules provide
+;;; similar functionality to nonsplicing letrec-syntax when the latter is
+;;; used as a definition.
+
+;;; Objects with no standard print syntax, including objects containing
+;;; cycles and syntax objects, are allowed in quoted data as long as they
+;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; Such objects are never copied.
+
+;;; When the expander encounters a reference to an identifier that has
+;;; no global or lexical binding, it treats it as a global-variable
+;;; reference. This allows one to write mutually recursive top-level
+;;; definitions, e.g.:
+;;;
+;;; (define f (lambda (x) (g x)))
+;;; (define g (lambda (x) (f x)))
+;;;
+;;; but may not always yield the intended when the variable in question
+;;; is later defined as a keyword.
+
+;;; Top-level variable definitions of syntax keywords are permitted.
+;;; In order to make this work, top-level define not only produces a
+;;; top-level definition in the core language, but also modifies the
+;;; compile-time environment (using $sc-put-cte) to record the fact
+;;; that the identifier is a variable.
+
+;;; Top-level definitions of macro-introduced identifiers are visible
+;;; only in code produced by the macro. That is, a binding for a
+;;; hidden (generated) identifier is created instead, and subsequent
+;;; references within the macro output are renamed accordingly. For
+;;; example:
+;;;
+;;; (define-syntax a
+;;; (syntax-rules ()
+;;; ((_ var exp)
+;;; (begin
+;;; (define secret exp)
+;;; (define var
+;;; (lambda ()
+;;; (set! secret (+ secret 17))
+;;; secret))))))
+;;; (a x 0)
+;;; (x) => 17
+;;; (x) => 34
+;;; secret => Error: variable secret is not bound
+;;;
+;;; The definition above would fail if the definition for secret
+;;; were placed after the definition for var, since the expander would
+;;; encounter the references to secret before the definition that
+;;; establishes the compile-time map from the identifier secret to
+;;; the generated identifier.
+
+;;; Identifiers and syntax objects are implemented as vectors for
+;;; portability. As a result, it is possible to "forge" syntax
+;;; objects.
+
+;;; The input to sc-expand may contain "annotations" describing, e.g., the
+;;; source file and character position from where each object was read if
+;;; it was read from a file. These annotations are handled properly by
+;;; sc-expand only if the annotation? hook (see hooks below) is implemented
+;;; properly and the operators make-annotation, annotation-expression,
+;;; annotation-source, annotation-stripped, and set-annotation-stripped!
+;;; are supplied. If annotations are supplied, the proper annotation
+;;; source is passed to the various output constructors, allowing
+;;; implementations to accurately correlate source and expanded code.
+;;; Contact one of the authors for details if you wish to make use of
+;;; this feature.
+
+;;; Implementation of modules:
+;;;
+;;; The implementation of modules requires that implicit top-level exports
+;;; be listed with the exported macro at some level where both are visible,
+;;; e.g.,
+;;;
+;;; (module M (alpha (beta b))
+;;; (module ((alpha a) b)
+;;; (define-syntax alpha (identifier-syntax a))
+;;; (define a 'a)
+;;; (define b 'b))
+;;; (define-syntax beta (identifier-syntax b)))
+;;;
+;;; Listing of implicit imports is not needed for macros that do not make
+;;; it out to top level, including all macros that are local to a "body".
+;;; (They may be listed in this case, however.) We need this information
+;;; for top-level modules since a top-level module expands into a letrec
+;;; for non-top-level variables and top-level definitions (assignments) for
+;;; top-level variables. Because of the general nature of macro
+;;; transformers, we cannot determine the set of implicit exports from the
+;;; transformer code, so without the user's help, we'd have to put all
+;;; variables at top level.
+;;;
+;;; Each such top-level identifier is given a generated name (gensym).
+;;; When a top-level module is imported at top level, a compile-time
+;;; alias is established from the top-level name to the generated name.
+;;; The expander follows these aliases transparently. When any module is
+;;; imported anywhere other than at top level, the id-var-name of the
+;;; import identifier is set to the id-var-name of the export identifier.
+;;; Since we can't determine the actual labels for identifiers defined in
+;;; top-level modules until we determine which are placed in the letrec
+;;; and which make it to top level, we give each an "indirect" label---a
+;;; pair whose car will eventually contain the actual label. Import does
+;;; not follow the indirect, but id-var-name does.
+;;;
+;;; All identifiers defined within a local module are folded into the
+;;; letrec created for the enclosing body. Visibility is controlled in
+;;; this case and for nested top-level modules by introducing a new wrap
+;;; for each module.
+
+
+;;; Bootstrapping:
+
+;;; When changing syntax-object representations, it is necessary to support
+;;; both old and new syntax-object representations in id-var-name. It
+;;; should be sufficient to recognize old representations and treat
+;;; them as not lexically bound.
+
+
+(let ()
+
+(define-syntax when
+ (syntax-rules ()
+ ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
+(define-syntax unless
+ (syntax-rules ()
+ ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
+(define-syntax define-structure
+ (lambda (x)
+ (define construct-name
+ (lambda (template-identifier . args)
+ (datum->syntax-object
+ template-identifier
+ (string->symbol
+ (apply string-append
+ (map (lambda (x)
+ (if (string? x)
+ x
+ (symbol->string (syntax-object->datum x))))
+ args))))))
+ (syntax-case x ()
+ ((_ (name id1 ...))
+ (andmap identifier? (syntax (name id1 ...)))
+ (with-syntax
+ ((constructor (construct-name (syntax name) "make-" (syntax name)))
+ (predicate (construct-name (syntax name) (syntax name) "?"))
+ ((access ...)
+ (map (lambda (x) (construct-name x (syntax name) "-" x))
+ (syntax (id1 ...))))
+ ((assign ...)
+ (map (lambda (x)
+ (construct-name x "set-" (syntax name) "-" x "!"))
+ (syntax (id1 ...))))
+ (structure-length
+ (+ (length (syntax (id1 ...))) 1))
+ ((index ...)
+ (let f ((i 1) (ids (syntax (id1 ...))))
+ (if (null? ids)
+ '()
+ (cons i (f (+ i 1) (cdr ids)))))))
+ (syntax (begin
+ (define constructor
+ (lambda (id1 ...)
+ (vector 'name id1 ... )))
+ (define predicate
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) structure-length)
+ (eq? (vector-ref x 0) 'name))))
+ (define access
+ (lambda (x)
+ (vector-ref x index)))
+ ...
+ (define assign
+ (lambda (x update)
+ (vector-set! x index update)))
+ ...)))))))
+
+(define noexpand "noexpand")
+
+;;; hooks to nonportable run-time helpers
+(begin
+(define-syntax fx+ (identifier-syntax +))
+(define-syntax fx- (identifier-syntax -))
+(define-syntax fx= (identifier-syntax =))
+(define-syntax fx< (identifier-syntax <))
+
+(define annotation? (lambda (x) #f))
+
+(define top-level-eval-hook
+ (lambda (x)
+ (eval `(,noexpand ,x))))
+
+(define local-eval-hook
+ (lambda (x)
+ (eval `(,noexpand ,x))))
+
+(define error-hook
+ (lambda (who why what)
+ (error who "~a ~s" why what)))
+
+(define-syntax gensym-hook
+ (syntax-rules ()
+ ((_) (gensym))))
+
+(define put-global-definition-hook
+ (lambda (symbol val)
+ ($sc-put-cte symbol val)))
+
+(define get-global-definition-hook
+ (lambda (symbol)
+ (getprop symbol '*sc-expander*)))
+
+(define get-import-binding
+ (lambda (symbol token)
+ (getprop symbol token)))
+
+(define generate-id
+ (let ((b (- 127 32 2)))
+ ; session-key should generate a unique integer for each system run
+ ; to support separate compilation
+ (define session-key (lambda () 0))
+ (define make-digit (lambda (x) (integer->char (fx+ x 33))))
+ (define fmt
+ (lambda (n)
+ (let fmt ((n n) (a '()))
+ (if (< n b)
+ (list->string (cons (make-digit n) a))
+ (let ((r (modulo n b)) (rest (quotient n b)))
+ (fmt rest (cons (make-digit r) a)))))))
+ (let ((prefix (fmt (session-key))) (n -1))
+ (lambda (name)
+ (set! n (+ n 1))
+ (let ((newsym (string->symbol (string-append "#" prefix (fmt n)))))
+ newsym)))))
+)
+
+
+;;; output constructors
+(begin
+(define-syntax build-application
+ (syntax-rules ()
+ ((_ source fun-exp arg-exps)
+ `(,fun-exp . ,arg-exps))))
+
+(define-syntax build-conditional
+ (syntax-rules ()
+ ((_ source test-exp then-exp else-exp)
+ `(if ,test-exp ,then-exp ,else-exp))))
+
+(define-syntax build-lexical-reference
+ (syntax-rules ()
+ ((_ type source var)
+ var)))
+
+(define-syntax build-lexical-assignment
+ (syntax-rules ()
+ ((_ source var exp)
+ `(set! ,var ,exp))))
+
+(define-syntax build-global-reference
+ (syntax-rules ()
+ ((_ source var)
+ var)))
+
+(define-syntax build-global-assignment
+ (syntax-rules ()
+ ((_ source var exp)
+ `(set! ,var ,exp))))
+
+(define-syntax build-global-definition
+ (syntax-rules ()
+ ((_ source var exp)
+ `(define ,var ,exp))))
+
+(define-syntax build-module-definition
+ ; should have the effect of a global definition but may not appear at top level
+ (identifier-syntax build-global-assignment))
+
+(define-syntax build-cte-install
+ ; should build a call that has the same effect as calling the
+ ; global definition hook
+ (syntax-rules ()
+ ((_ sym exp) `($sc-put-cte ',sym ,exp))))
+
+(define-syntax build-lambda
+ (syntax-rules ()
+ ((_ src vars exp)
+ `(lambda ,vars ,exp))))
+
+(define-syntax build-primref
+ (syntax-rules ()
+ ((_ src name) name)
+ ((_ src level name) name)))
+
+(define-syntax build-data
+ (syntax-rules ()
+ ((_ src exp) `',exp)))
+
+(define build-sequence
+ (lambda (src exps)
+ (if (null? (cdr exps))
+ (car exps)
+ `(begin ,@exps))))
+
+(define build-letrec
+ (lambda (src vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ `(letrec ,(map list vars val-exps) ,body-exp))))
+
+(define-syntax build-lexical-var
+ (syntax-rules ()
+ ((_ src id) (gensym))))
+
+(define-syntax self-evaluating?
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
+)
+
+(define-structure (syntax-object expression wrap))
+
+(define-syntax unannotate
+ (syntax-rules ()
+ ((_ x)
+ (let ((e x))
+ (if (annotation? e)
+ (annotation-expression e)
+ e)))))
+
+(define-syntax no-source (identifier-syntax #f))
+
+(define source-annotation
+ (lambda (x)
+ (cond
+ ((annotation? x) (annotation-source x))
+ ((syntax-object? x) (source-annotation (syntax-object-expression x)))
+ (else no-source))))
+
+(define-syntax arg-check
+ (syntax-rules ()
+ ((_ pred? e who)
+ (let ((x e))
+ (if (not (pred? x)) (error-hook who "invalid argument" x))))))
+
+;;; compile-time environments
+
+;;; wrap and environment comprise two level mapping.
+;;; wrap : id --> label
+;;; env : label --> <element>
+
+;;; environments are represented in two parts: a lexical part and a global
+;;; part. The lexical part is a simple list of associations from labels
+;;; to bindings. The global part is implemented by
+;;; {put,get}-global-definition-hook and associates symbols with
+;;; bindings.
+
+;;; global (assumed global variable) and displaced-lexical (see below)
+;;; do not show up in any environment; instead, they are fabricated by
+;;; lookup when it finds no other bindings.
+
+;;; <environment> ::= ((<label> . <binding>)*)
+
+;;; identifier bindings include a type and a value
+
+;;; <binding> ::= (macro . <procedure>) macros
+;;; (deferred . <expanded code>) lazy-evaluation of transformers
+;;; (core . <procedure>) core forms
+;;; (begin) begin
+;;; (define) define
+;;; (define-syntax) define-syntax
+;;; (local-syntax . rec?) let-syntax/letrec-syntax
+;;; (eval-when) eval-when
+;;; (syntax . (<var> . <level>)) pattern variables
+;;; (global . <symbol>) assumed global variable
+;;; (lexical . <var>) lexical variables
+;;; (displaced-lexical . #f) id-var-name not found in store
+;;; <level> ::= <nonnegative integer>
+;;; <var> ::= variable returned by build-lexical-var
+
+;;; a macro is a user-defined syntactic-form. a core is a system-defined
+;;; syntactic form. begin, define, define-syntax, and eval-when are
+;;; treated specially since they are sensitive to whether the form is
+;;; at top-level and (except for eval-when) can denote valid internal
+;;; definitions.
+
+;;; a pattern variable is a variable introduced by syntax-case and can
+;;; be referenced only within a syntax form.
+
+;;; any identifier for which no top-level syntax definition or local
+;;; binding of any kind has been seen is assumed to be a global
+;;; variable.
+
+;;; a lexical variable is a lambda- or letrec-bound variable.
+
+;;; a displaced-lexical identifier is a lexical identifier removed from
+;;; it's scope by the return of a syntax object containing the identifier.
+;;; a displaced lexical can also appear when a letrec-syntax-bound
+;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
+;;; a displaced lexical should never occur with properly written macros.
+
+(define make-binding (lambda (x y) (cons x y)))
+(define binding-type car)
+(define binding-value cdr)
+(define set-binding-type! set-car!)
+(define set-binding-value! set-cdr!)
+(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
+
+(define-syntax null-env (identifier-syntax '()))
+
+(define extend-env
+ (lambda (label binding r)
+ (cons (cons label binding) r)))
+
+(define extend-env*
+ (lambda (labels bindings r)
+ (if (null? labels)
+ r
+ (extend-env* (cdr labels) (cdr bindings)
+ (extend-env (car labels) (car bindings) r)))))
+
+(define extend-var-env*
+ ; variant of extend-env* that forms "lexical" binding
+ (lambda (labels vars r)
+ (if (null? labels)
+ r
+ (extend-var-env* (cdr labels) (cdr vars)
+ (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
+
+;;; we use a "macros only" environment in expansion of local macro
+;;; definitions so that their definitions can use local macros without
+;;; attempting to use other lexical identifiers.
+;;;
+;;; - can make this null-env if we don't want to allow macros to use other
+;;; macros in defining their transformers
+;;; - can add a cache here if it pays off
+(define transformer-env
+ (lambda (r)
+ (if (null? r)
+ '()
+ (let ((a (car r)))
+ (if (eq? (cadr a) 'lexical) ; only strip out lexical so that (transformer x) works
+ (transformer-env (cdr r))
+ (cons a (transformer-env (cdr r))))))))
+
+(define displaced-lexical-error
+ (lambda (id)
+ (syntax-error id
+ (if (id-var-name id empty-wrap)
+ "identifier out of context"
+ "identifier not visible"))))
+
+(define lookup*
+ ; x may be a label or a symbol
+ ; although symbols are usually global, we check the environment first
+ ; anyway because a temporary binding may have been established by
+ ; fluid-let-syntax
+ (lambda (x r)
+ (cond
+ ((assq x r) => cdr)
+ ((symbol? x)
+ (or (get-global-definition-hook x) (make-binding 'global x)))
+ (else (make-binding 'displaced-lexical #f)))))
+
+(define sanitize-binding
+ (lambda (b)
+ (cond
+ ((procedure? b) (make-binding 'macro b))
+ ((binding? b)
+ (case (binding-type b)
+ ((core macro macro!) (and (procedure? (binding-value b)) b))
+ ((module) (and (interface? (binding-value b)) b))
+ (else b)))
+ (else #f))))
+
+(define lookup
+ (lambda (x r)
+ (define whack-binding!
+ (lambda (b *b)
+ (set-binding-type! b (binding-type *b))
+ (set-binding-value! b (binding-value *b))))
+ (let ((b (lookup* x r)))
+ (case (binding-type b)
+; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
+ ((deferred)
+ (whack-binding! b
+ (let ((*b (local-eval-hook (binding-value b))))
+ (or (sanitize-binding *b)
+ (syntax-error *b "invalid transformer"))))
+ (case (binding-type b)
+; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
+ (else b)))
+ (else b)))))
+
+(define global-extend
+ (lambda (type sym val)
+ (put-global-definition-hook sym (make-binding type val))))
+
+
+;;; Conceptually, identifiers are always syntax objects. Internally,
+;;; however, the wrap is sometimes maintained separately (a source of
+;;; efficiency and confusion), so that symbols are also considered
+;;; identifiers by id?. Externally, they are always wrapped.
+
+(define nonsymbol-id?
+ (lambda (x)
+ (and (syntax-object? x)
+ (symbol? (unannotate (syntax-object-expression x))))))
+
+(define id?
+ (lambda (x)
+ (cond
+ ((symbol? x) #t)
+ ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
+ ((annotation? x) (symbol? (annotation-expression x)))
+ (else #f))))
+
+(define-syntax id-sym-name
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
+
+(define id-sym-name&marks
+ (lambda (x w)
+ (if (syntax-object? x)
+ (values
+ (unannotate (syntax-object-expression x))
+ (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (values (unannotate x) (wrap-marks w)))))
+
+;;; syntax object wraps
+
+;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+;;; <subst> ::= <ribcage> | <shift>
+;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
+;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
+;;; <ex-symname> ::= <symname> | <import token> | <barrier>
+;;; <shift> ::= shift
+;;; <barrier> ::= #f ; inserted by import-only
+;;; <import token> ::= #<"import-token" <token>>
+;;; <token> ::= <generated id>
+
+(define make-wrap cons)
+(define wrap-marks car)
+(define wrap-subst cdr)
+
+(define-syntax subst-rename? (identifier-syntax vector?))
+(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
+(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
+(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
+(define-syntax make-rename
+ (syntax-rules ()
+ ((_ old new marks) (vector old new marks))))
+
+;;; labels
+
+;;; simple labels must be comparable with "eq?" and distinct from symbols
+;;; and pairs.
+
+;;; indirect labels, which are implemented as pairs, are used to support
+;;; import aliasing for identifiers exported (explictly or implicitly) from
+;;; top-level modules. chi-external creates an indirect label for each
+;;; defined identifier, import causes the pair to be shared aliases it
+;;; establishes, and chi-top-module whacks the pair to hold the top-level
+;;; identifier name (symbol) if the id is to be placed at top level, before
+;;; expanding the right-hand sides of the definitions in the module.
+
+(define gen-label
+ (lambda () (string #\i)))
+(define label?
+ (lambda (x)
+ (or (string? x) ; normal lexical labels
+ (symbol? x) ; global labels (symbolic names)
+ (indirect-label? x))))
+
+(define gen-labels
+ (lambda (ls)
+ (if (null? ls)
+ '()
+ (cons (gen-label) (gen-labels (cdr ls))))))
+
+(define gen-indirect-label
+ (lambda () (list (gen-label))))
+
+(define indirect-label? pair?)
+(define get-indirect-label car)
+(define set-indirect-label! set-car!)
+
+(define-structure (ribcage symnames marks labels))
+(define-syntax empty-wrap (identifier-syntax '(())))
+
+(define-syntax top-wrap (identifier-syntax '((top))))
+
+(define-syntax top-marked?
+ (syntax-rules ()
+ ((_ w) (memq 'top (wrap-marks w)))))
+
+(define-syntax only-top-marked?
+ (syntax-rules ()
+ ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
+
+;;; Marks must be comparable with "eq?" and distinct from pairs and
+;;; the symbol top. We do not use integers so that marks will remain
+;;; unique even across file compiles.
+
+(define-syntax the-anti-mark (identifier-syntax #f))
+
+(define anti-mark
+ (lambda (w)
+ (make-wrap (cons the-anti-mark (wrap-marks w))
+ (cons 'shift (wrap-subst w)))))
+
+(define-syntax new-mark
+ (syntax-rules ()
+ ((_) (string #\m))))
+
+(define barrier-marker #f)
+(module (make-import-token import-token? import-token-key)
+ (define tag 'import-token)
+ (define make-import-token (lambda (x) (cons tag x)))
+ (define import-token? (lambda (x) (and (pair? x) (eq? (car x) tag))))
+ (define import-token-key cdr))
+
+;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
+;;; internal definitions, in which the ribcages are built incrementally
+(define-syntax make-empty-ribcage
+ (syntax-rules ()
+ ((_) (make-ribcage '() '() '()))))
+
+(define extend-ribcage!
+ ; must receive ids with complete wraps
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage id label)
+ (set-ribcage-symnames! ribcage
+ (cons (unannotate (syntax-object-expression id))
+ (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks (syntax-object-wrap id))
+ (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage
+ (cons label (ribcage-labels ribcage)))))
+
+(define extend-ribcage-barrier!
+ ; must receive ids with complete wraps
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage killer-id)
+ (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
+
+(define extend-ribcage-barrier-help!
+ (lambda (ribcage wrap)
+ (set-ribcage-symnames! ribcage
+ (cons barrier-marker (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
+
+(define extend-ribcage-subst!
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage token)
+ (set-ribcage-symnames! ribcage
+ (cons (make-import-token token) (ribcage-symnames ribcage)))))
+
+(define lookup-import-binding-name
+ (lambda (sym key marks)
+ (let ((new (get-import-binding sym key)))
+ (and new
+ (let f ((new new))
+ (cond
+ ((pair? new) (or (f (car new)) (f (cdr new))))
+ ((same-marks? marks (wrap-marks (syntax-object-wrap new))) new)
+ (else #f)))))))
+
+;;; make-binding-wrap creates vector-based ribcages
+(define make-binding-wrap
+ (lambda (ids labels w)
+ (if (null? ids)
+ w
+ (make-wrap
+ (wrap-marks w)
+ (cons
+ (let ((labelvec (list->vector labels)))
+ (let ((n (vector-length labelvec)))
+ (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
+ (let f ((ids ids) (i 0))
+ (if (not (null? ids))
+ (call-with-values
+ (lambda () (id-sym-name&marks (car ids) w))
+ (lambda (symname marks)
+ (vector-set! symnamevec i symname)
+ (vector-set! marksvec i marks)
+ (f (cdr ids) (fx+ i 1))))))
+ (make-ribcage symnamevec marksvec labelvec))))
+ (wrap-subst w))))))
+
+;;; make-trimmed-syntax-object is used by make-resolved-interface to support
+;;; creation of module export lists whose constituent ids do not contain
+;;; unnecessary substitutions or marks.
+(define make-trimmed-syntax-object
+ (lambda (id)
+ (call-with-values
+ (lambda () (id-var-name&marks id empty-wrap))
+ (lambda (tosym marks)
+ (unless tosym
+ (syntax-error id "identifier not visible for export"))
+ (let ((fromsym (id-sym-name id)))
+ (make-syntax-object fromsym
+ (make-wrap marks
+ (list (make-ribcage (vector fromsym) (vector marks) (vector tosym))))))))))
+
+;;; Scheme's append should not copy the first argument if the second is
+;;; nil, but it does, so we define a smart version here.
+(define smart-append
+ (lambda (m1 m2)
+ (if (null? m2)
+ m1
+ (append m1 m2))))
+
+(define join-wraps
+ (lambda (w1 w2)
+ (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
+ (if (null? m1)
+ (if (null? s1)
+ w2
+ (make-wrap
+ (wrap-marks w2)
+ (smart-append s1 (wrap-subst w2))))
+ (make-wrap
+ (smart-append m1 (wrap-marks w2))
+ (smart-append s1 (wrap-subst w2)))))))
+
+(define join-marks
+ (lambda (m1 m2)
+ (smart-append m1 m2)))
+
+(define same-marks?
+ (lambda (x y)
+ (or (eq? x y)
+ (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y))
+ (same-marks? (cdr x) (cdr y))))))
+
+(define id-var-name-loc&marks
+ (lambda (id w)
+ (define search
+ (lambda (sym subst marks)
+ (if (null? subst)
+ (values sym marks)
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (search sym (cdr subst) (cdr marks))
+ (let ((symnames (ribcage-symnames fst)))
+ (if (vector? symnames)
+ (search-vector-rib sym subst marks symnames fst)
+ (search-list-rib sym subst marks symnames fst))))))))
+ (define search-list-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let f ((symnames symnames) (i 0))
+ (cond
+ ((null? symnames) (search sym (cdr subst) marks))
+ ((and (eq? (car symnames) sym)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values (list-ref (ribcage-labels ribcage) i) marks))
+ ((import-token? (car symnames))
+ (cond
+ ((lookup-import-binding-name sym (import-token-key (car symnames)) marks) =>
+ (lambda (id)
+ (if (symbol? id)
+ (values id marks)
+ (id-var-name&marks id empty-wrap)))) ; could be more efficient: new is a resolved id
+ (else (f (cdr symnames) i))))
+ ((and (eq? (car symnames) barrier-marker)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values #f marks))
+ (else (f (cdr symnames) (fx+ i 1)))))))
+ (define search-vector-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0))
+ (cond
+ ((fx= i n) (search sym (cdr subst) marks))
+ ((and (eq? (vector-ref symnames i) sym)
+ (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
+ (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (else (f (fx+ i 1))))))))
+ (cond
+ ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
+ ((syntax-object? id)
+ (let ((sym (unannotate (syntax-object-expression id)))
+ (w1 (syntax-object-wrap id)))
+ (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
+ (call-with-values (lambda () (search sym (wrap-subst w) marks))
+ (lambda (new-id marks)
+ (if (eq? new-id sym)
+ (search sym (wrap-subst w1) marks)
+ (values new-id marks)))))))
+ ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
+ (else (error-hook 'id-var-name "invalid id" id)))))
+
+(define id-var-name&marks
+ ; this version follows indirect labels
+ (lambda (id w)
+ (call-with-values
+ (lambda () (id-var-name-loc&marks id w))
+ (lambda (label marks)
+ (values (if (indirect-label? label) (get-indirect-label label) label) marks)))))
+
+(define id-var-name-loc
+ ; this version doesn't follow indirect labels
+ (lambda (id w)
+ (call-with-values
+ (lambda () (id-var-name-loc&marks id w))
+ (lambda (label marks) label))))
+
+(define id-var-name
+ ; this version follows indirect labels
+ (lambda (id w)
+ (call-with-values
+ (lambda () (id-var-name-loc&marks id w))
+ (lambda (label marks)
+ (if (indirect-label? label) (get-indirect-label label) label)))))
+
+;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
+;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
+
+(define free-id=?
+ (lambda (i j)
+ (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
+ (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
+
+(define-syntax literal-id=? (identifier-syntax free-id=?))
+
+;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
+;;; long as the missing portion of the wrap is common to both of the ids
+;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
+
+(define bound-id=?
+ (lambda (i j)
+ (if (and (syntax-object? i) (syntax-object? j))
+ (and (eq? (unannotate (syntax-object-expression i))
+ (unannotate (syntax-object-expression j)))
+ (same-marks? (wrap-marks (syntax-object-wrap i))
+ (wrap-marks (syntax-object-wrap j))))
+ (eq? (unannotate i) (unannotate j)))))
+
+;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
+;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
+;;; as long as the missing portion of the wrap is common to all of the
+;;; ids.
+
+(define valid-bound-ids?
+ (lambda (ids)
+ (and (let all-ids? ((ids ids))
+ (or (null? ids)
+ (and (id? (car ids))
+ (all-ids? (cdr ids)))))
+ (distinct-bound-ids? ids))))
+
+;;; distinct-bound-ids? expects a list of ids and returns #t if there are
+;;; no duplicates. It is quadratic on the length of the id list; long
+;;; lists could be sorted to make it more efficient. distinct-bound-ids?
+;;; may be passed unwrapped (or partially wrapped) ids as long as the
+;;; missing portion of the wrap is common to all of the ids.
+
+(define distinct-bound-ids?
+ (lambda (ids)
+ (let distinct? ((ids ids))
+ (or (null? ids)
+ (and (not (bound-id-member? (car ids) (cdr ids)))
+ (distinct? (cdr ids)))))))
+
+(define invalid-ids-error
+ ; find first bad one and complain about it
+ (lambda (ids exp class)
+ (let find ((ids ids) (gooduns '()))
+ (if (null? ids)
+ (syntax-error exp) ; shouldn't happen
+ (if (id? (car ids))
+ (if (bound-id-member? (car ids) gooduns)
+ (syntax-error (car ids) "duplicate " class)
+ (find (cdr ids) (cons (car ids) gooduns)))
+ (syntax-error (car ids) "invalid " class))))))
+
+(define bound-id-member?
+ (lambda (x list)
+ (and (not (null? list))
+ (or (bound-id=? x (car list))
+ (bound-id-member? x (cdr list))))))
+
+;;; wrapping expressions and identifiers
+
+(define wrap
+ (lambda (x w)
+ (cond
+ ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
+ ((syntax-object? x)
+ (make-syntax-object
+ (syntax-object-expression x)
+ (join-wraps w (syntax-object-wrap x))))
+ ((null? x) x)
+ (else (make-syntax-object x w)))))
+
+(define source-wrap
+ (lambda (x w s)
+ (wrap (if s (make-annotation x s #f) x) w)))
+
+;;; expanding
+
+(define chi-sequence
+ (lambda (body r w s)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w))
+ (if (null? body)
+ '()
+ (let ((first (chi (car body) r w)))
+ (cons first (dobody (cdr body) r w))))))))
+
+(define chi-top-sequence
+ (lambda (body r w s m esew ribcage)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w) (m m) (esew esew))
+ (if (null? body)
+ '()
+ (let ((first (chi-top (car body) r w m esew ribcage)))
+ (cons first (dobody (cdr body) r w m esew))))))))
+
+(define chi-when-list
+ (lambda (e when-list w)
+ ; when-list is syntax'd version of list of situations
+ (let f ((when-list when-list) (situations '()))
+ (if (null? when-list)
+ situations
+ (f (cdr when-list)
+ (cons (let ((x (car when-list)))
+ (cond
+ ((literal-id=? x (syntax compile)) 'compile)
+ ((literal-id=? x (syntax load)) 'load)
+ ((literal-id=? x (syntax eval)) 'eval)
+ (else (syntax-error (wrap x w)
+ "invalid eval-when situation"))))
+ situations))))))
+
+;;; syntax-type returns five values: type, value, e, w, and s. The first
+;;; two are described in the table below.
+;;;
+;;; type value explanation
+;;; -------------------------------------------------------------------
+;;; begin none begin keyword
+;;; begin-form none begin expression
+;;; call none any other call
+;;; constant none self-evaluating datum
+;;; core procedure core form (including singleton)
+;;; define none define keyword
+;;; define-form none variable definition
+;;; define-syntax none define-syntax keyword
+;;; define-syntax-form none syntax definition
+;;; displaced-lexical none displaced lexical identifier
+;;; eval-when none eval-when keyword
+;;; eval-when-form none eval-when form
+;;; global name global variable reference
+;;; import none import keyword
+;;; import-form none import form
+;;; lexical name lexical variable reference
+;;; lexical-call name call to lexical variable
+;;; local-syntax rec? letrec-syntax/let-syntax keyword
+;;; local-syntax-form rec? syntax definition
+;;; module none module keyword
+;;; module-form none module definition
+;;; other none anything else
+;;; syntax level pattern variable
+;;;
+;;; For all forms, e is the form, w is the wrap for e. and s is the source.
+;;;
+;;; syntax-type expands macros and unwraps as necessary to get to
+;;; one of the forms above.
+
+(define syntax-type
+ (lambda (e r w s rib)
+ (cond
+ ((symbol? e)
+ (let* ((n (id-var-name e w))
+ (b (lookup n r))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values type (binding-value b) e w s))
+ ((global) (values type (binding-value b) e w s))
+ ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w s rib) r empty-wrap #f rib))
+ (else (values type (binding-value b) e w s)))))
+ ((pair? e)
+ (let ((first (car e)))
+ (if (id? first)
+ (let* ((n (id-var-name first w))
+ (b (lookup n r))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values 'lexical-call (binding-value b) e w s))
+ ((macro macro!)
+ (syntax-type (chi-macro (binding-value b) e r w s rib)
+ r empty-wrap #f rib))
+ ((core) (values type (binding-value b) e w s))
+ ((local-syntax)
+ (values 'local-syntax-form (binding-value b) e w s))
+ ((begin) (values 'begin-form #f e w s))
+ ((eval-when) (values 'eval-when-form #f e w s))
+ ((define) (values 'define-form #f e w s))
+ ((define-syntax) (values 'define-syntax-form #f e w s))
+ ((module-key) (values 'module-form #f e w s))
+ ((import) (values 'import-form (and (binding-value b) (wrap first w)) e w s))
+ ((set!) (chi-set! e r w s rib))
+ (else (values 'call #f e w s))))
+ (values 'call #f e w s))))
+ ((syntax-object? e)
+ ;; s can't be valid source if we've unwrapped
+ (syntax-type (syntax-object-expression e)
+ r
+ (join-wraps w (syntax-object-wrap e))
+ no-source rib))
+ ((annotation? e)
+ (syntax-type (annotation-expression e) r w (annotation-source e) rib))
+ ((self-evaluating? e) (values 'constant #f e w s))
+ (else (values 'other #f e w s)))))
+
+(define chi-top-expr
+ (lambda (e r w top-ribcage)
+ (call-with-values
+ (lambda () (syntax-type e r w no-source top-ribcage))
+ (lambda (type value e w s)
+ (chi-expr type value e r w s)))))
+
+(define chi-top
+ (lambda (e r w m esew top-ribcage)
+ (define-syntax eval-if-c&e
+ (syntax-rules ()
+ ((_ m e)
+ (let ((x e))
+ (if (eq? m 'c&e) (top-level-eval-hook x))
+ x))))
+ (call-with-values
+ (lambda () (syntax-type e r w no-source top-ribcage))
+ (lambda (type value e w s)
+ (case type
+ ((begin-form)
+ (syntax-case e ()
+ ((_) (chi-void))
+ ((_ e1 e2 ...)
+ (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew top-ribcage))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s
+ (lambda (body r w s)
+ (chi-top-sequence body r w s m esew top-ribcage))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e (syntax (x ...)) w))
+ (body (syntax (e1 e2 ...))))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (chi-top-sequence body r w s 'e '(eval) top-ribcage)
+ (chi-void)))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (chi-top-sequence body r w s 'c&e '(compile load) top-ribcage)
+ (if (memq m '(c c&e))
+ (chi-top-sequence body r w s 'c '(load) top-ribcage)
+ (chi-void))))
+ ((or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (chi-top-sequence body r w s 'e '(eval) top-ribcage))
+ (chi-void))
+ (else (chi-void)))))))
+ ((define-syntax-form)
+ (parse-define-syntax e w s
+ (lambda (id rhs w)
+ (let ((id (wrap id w)))
+ (let ((n (id-var-name id empty-wrap)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((displaced-lexical) (displaced-lexical-error id)))))
+ (ct-eval/residualize m esew
+ (lambda ()
+ (build-cte-install
+ (let ((sym (id-sym-name id)))
+ (if (only-top-marked? id)
+ sym
+ (let ((marks (wrap-marks (syntax-object-wrap id))))
+ (make-syntax-object sym
+ (make-wrap marks
+ (list (make-ribcage (vector sym)
+ (vector marks) (vector (generate-id sym)))))))))
+ (chi rhs (transformer-env r) w))))))))
+ ((define-form)
+ (parse-define e w s
+ (lambda (id rhs w)
+ (let ((id (wrap id w)))
+ (let ((n (id-var-name id empty-wrap)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((displaced-lexical) (displaced-lexical-error id)))))
+ (let ((sym (id-sym-name id)))
+ (let ((valsym (if (only-top-marked? id) sym (generate-id sym))))
+ (build-sequence no-source
+ (list
+ (ct-eval/residualize m esew
+ (lambda ()
+ (build-cte-install
+ (if (eq? sym valsym)
+ sym
+ (let ((marks (wrap-marks (syntax-object-wrap id))))
+ (make-syntax-object sym
+ (make-wrap marks
+ (list (make-ribcage (vector sym)
+ (vector marks) (vector valsym)))))))
+ (build-data no-source (make-binding 'global valsym)))))
+ (eval-if-c&e m (build-global-definition s valsym (chi rhs r w))))))
+ )))))
+ ((module-form)
+ (let ((r (cons '("top-level module placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage)))
+ (parse-module e w s (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))
+ (lambda (id exports forms)
+ (if id
+ (begin
+ (let ((n (id-var-name id empty-wrap)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((displaced-lexical) (displaced-lexical-error (wrap id w))))))
+ (chi-top-module e r ribcage w s m esew id exports forms))
+ (chi-top-module e r ribcage w s m esew #f exports forms))))))
+ ((import-form)
+ (parse-import e w s
+ (lambda (mid)
+ (ct-eval/residualize m esew
+ (lambda ()
+ (when value (syntax-error (source-wrap e w s) "not valid at top-level"))
+ (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
+ (case (binding-type binding)
+ ((module) (do-top-import mid (interface-token (binding-value binding))))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "import from unknown module")))))))))
+ (else (eval-if-c&e m (chi-expr type value e r w s))))))))
+
+(define flatten-exports
+ (lambda (exports)
+ (let loop ((exports exports) (ls '()))
+ (if (null? exports)
+ ls
+ (loop (cdr exports)
+ (if (pair? (car exports))
+ (loop (car exports) ls)
+ (cons (car exports) ls)))))))
+
+
+(define-structure (interface exports token))
+
+(define make-trimmed-interface
+ ; trim out implicit exports
+ (lambda (exports)
+ (make-interface
+ (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
+ #f)))
+
+(define make-resolved-interface
+ ; trim out implicit exports & resolve others to actual top-level symbol
+ (lambda (exports import-token)
+ (make-interface
+ (list->vector (map (lambda (x) (make-trimmed-syntax-object (if (pair? x) (car x) x))) exports))
+ import-token)))
+
+(define-structure (module-binding type id label imps val))
+
+(define chi-top-module
+ (lambda (e r ribcage w s m esew id exports forms)
+ (let ((fexports (flatten-exports exports)))
+ (chi-external ribcage (source-wrap e w s)
+ (map (lambda (d) (cons r d)) forms) r exports fexports m esew
+ (lambda (bindings inits)
+ ; dvs & des: "defined" (letrec-bound) vars & rhs expressions
+ ; svs & ses: "set!" (top-level) vars & rhs expressions
+ (let partition ((fexports fexports) (bs bindings) (svs '()) (ses '()) (ctdefs '()))
+ (if (null? fexports)
+ ; remaining bindings are either local vars or local macros/modules
+ (let partition ((bs bs) (dvs '()) (des '()))
+ (if (null? bs)
+ (let ((ses (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) ses))
+ (des (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) des))
+ (inits (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) inits)))
+ ; we wait to do this here so that expansion of des & ses use
+ ; local versions, which in particular, allows us to use macros
+ ; locally even if esew tells us not to eval them
+ (for-each (lambda (x)
+ (apply (lambda (t label sym val)
+ (when label (set-indirect-label! label sym)))
+ x))
+ ctdefs)
+ (build-sequence no-source
+ (list (ct-eval/residualize m esew
+ (lambda ()
+ (if (null? ctdefs)
+ (chi-void)
+ (build-sequence no-source
+ (map (lambda (x)
+ (apply (lambda (t label sym val)
+ (build-cte-install sym
+ (if (eq? t 'define-syntax-form)
+ val
+ (build-data no-source
+ (make-binding 'module
+ (make-resolved-interface val sym))))))
+ x))
+ ctdefs)))))
+ (ct-eval/residualize m esew
+ (lambda ()
+ (let ((n (if id (id-sym-name id) #f)))
+ (let* ((token (generate-id n))
+ (b (build-data no-source
+ (make-binding 'module
+ (make-resolved-interface exports token)))))
+ (if n
+ (build-cte-install
+ (if (only-top-marked? id)
+ n
+ (let ((marks (wrap-marks (syntax-object-wrap id))))
+ (make-syntax-object n
+ (make-wrap marks
+ (list (make-ribcage (vector n)
+ (vector marks) (vector (generate-id n))))))))
+ b)
+ (let ((n (generate-id 'tmp)))
+ (build-sequence no-source
+ (list (build-cte-install n b)
+ (do-top-import n token)))))))))
+ ; Some systems complain when undefined variables are assigned.
+ (build-sequence no-source
+ (map (lambda (v) (build-global-definition no-source v (chi-void))) svs))
+ (build-letrec no-source
+ dvs
+ des
+ (build-sequence no-source
+ (list
+ (if (null? svs)
+ (chi-void)
+ (build-sequence no-source
+ (map (lambda (v e)
+ (build-module-definition no-source v e))
+ svs
+ ses)))
+ (if (null? inits)
+ (chi-void)
+ (build-sequence no-source inits)))))
+ (chi-void))))
+ (let ((b (car bs)))
+ (case (module-binding-type b)
+ ((define-form)
+ (let ((var (gen-var (module-binding-id b))))
+ (extend-store! r
+ (get-indirect-label (module-binding-label b))
+ (make-binding 'lexical var))
+ (partition (cdr bs) (cons var dvs)
+ (cons (module-binding-val b) des))))
+ ((define-syntax-form module-form) (partition (cdr bs) dvs des))
+ (else (error 'sc-expand-internal "unexpected module binding type"))))))
+ (let ((id (car fexports)) (fexports (cdr fexports)))
+ (define pluck-binding
+ (lambda (id bs succ fail)
+ (let loop ((bs bs) (new-bs '()))
+ (if (null? bs)
+ (fail)
+ (if (bound-id=? (module-binding-id (car bs)) id)
+ (succ (car bs) (smart-append (reverse new-bs) (cdr bs)))
+ (loop (cdr bs) (cons (car bs) new-bs)))))))
+ (pluck-binding id bs
+ (lambda (b bs)
+ (let ((t (module-binding-type b))
+ (label (module-binding-label b))
+ (imps (module-binding-imps b)))
+ (let ((fexports (append imps fexports))
+ (sym (generate-id (id-sym-name id))))
+ (case t
+ ((define-form)
+ (set-indirect-label! label sym)
+ (partition fexports bs (cons sym svs)
+ (cons (module-binding-val b) ses)
+ ctdefs))
+ ((define-syntax-form)
+ (partition fexports bs svs ses
+ (cons (list t label sym (module-binding-val b)) ctdefs)))
+ ((module-form)
+ (let ((exports (module-binding-val b)))
+ (partition (append (flatten-exports exports) fexports) bs
+ svs ses
+ (cons (list t label sym exports) ctdefs))))
+ (else (error 'sc-expand-internal "unexpected module binding type"))))))
+ (lambda () (partition fexports bs svs ses ctdefs)))))))))))
+
+(define id-set-diff
+ (lambda (exports defs)
+ (cond
+ ((null? exports) '())
+ ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
+ (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
+
+(define extend-store!
+ (lambda (r label binding)
+ (set-cdr! r (extend-env label binding (cdr r)))))
+
+(define check-module-exports
+ ; After processing the definitions of a module this is called to verify that the
+ ; module has defined or imported each exported identifier. Because ids in fexports are
+ ; wrapped with the given ribcage, they will contain substitutions for anything defined
+ ; or imported here. These subsitutions can be used by do-import! and do-import-top! to
+ ; provide access to reexported bindings, for example.
+ (lambda (source-exp fexports ids)
+ (define defined?
+ (lambda (e ids)
+ (ormap (lambda (x)
+ (if (interface? x)
+ (let ((token (interface-token x)))
+ (if token
+ (lookup-import-binding-name (id-sym-name e) token (wrap-marks (syntax-object-wrap e)))
+ (let ((v (interface-exports x)))
+ (let lp ((i (fx- (vector-length v) 1)))
+ (and (fx>= i 0)
+ (or (bound-id=? e (vector-ref v i))
+ (lp (fx- i 1))))))))
+ (bound-id=? e x)))
+ ids)))
+ (let loop ((fexports fexports) (missing '()))
+ (if (null? fexports)
+ (unless (null? missing) (syntax-error missing "missing definition for export(s)"))
+ (let ((e (car fexports)) (fexports (cdr fexports)))
+ (if (defined? e ids)
+ (loop fexports missing)
+ (loop fexports (cons e missing))))))))
+
+(define check-defined-ids
+ (lambda (source-exp ls)
+ (define b-i=?
+ ; cope with fat-fingered top-level
+ (lambda (x y)
+ (if (symbol? x)
+ (if (symbol? y)
+ (eq? x y)
+ (and (eq? x (id-sym-name y))
+ (same-marks? (wrap-marks (syntax-object-wrap y)) (wrap-marks top-wrap))))
+ (if (symbol? y)
+ (and (eq? y (id-sym-name x))
+ (same-marks? (wrap-marks (syntax-object-wrap x)) (wrap-marks top-wrap)))
+ (bound-id=? x y)))))
+ (define vfold
+ (lambda (v p cls)
+ (let ((len (vector-length v)))
+ (let lp ((i 0) (cls cls))
+ (if (fx= i len)
+ cls
+ (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
+ (define conflicts
+ (lambda (x y cls)
+ (if (interface? x)
+ (if (interface? y)
+ (call-with-values
+ (lambda ()
+ (let ((xe (interface-exports x)) (ye (interface-exports y)))
+ (if (fx> (vector-length xe) (vector-length ye))
+ (values x ye)
+ (values y xe))))
+ (lambda (iface exports)
+ (vfold exports (lambda (id cls) (id-iface-conflicts id iface cls)) cls)))
+ (id-iface-conflicts y x cls))
+ (if (interface? y)
+ (id-iface-conflicts x y cls)
+ (if (b-i=? x y) (cons x cls) cls)))))
+ (define id-iface-conflicts
+ (lambda (id iface cls)
+ (let ((token (interface-token iface)))
+ (if token
+ (if (lookup-import-binding-name (id-sym-name id) token
+ (if (symbol? id)
+ (wrap-marks top-wrap)
+ (wrap-marks (syntax-object-wrap id))))
+ (cons id cls)
+ cls)
+ (vfold (interface-exports iface)
+ (lambda (*id cls) (if (b-i=? *id id) (cons *id cls) cls))
+ cls)))))
+ (unless (null? ls)
+ (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
+ (if (null? ls)
+ (unless (null? cls)
+ (let ((cls (syntax-object->datum cls)))
+ (syntax-error source-exp "duplicate definition for "
+ (symbol->string (car cls))
+ " in")))
+ (let lp2 ((ls2 ls) (cls cls))
+ (if (null? ls2)
+ (lp (car ls) (cdr ls) cls)
+ (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
+
+(define chi-external
+ (lambda (ribcage source-exp body r exports fexports m esew k)
+ (define return
+ (lambda (bindings ids inits)
+ (check-defined-ids source-exp ids)
+ (check-module-exports source-exp fexports ids)
+ (k bindings inits)))
+ (define get-implicit-exports
+ (lambda (id)
+ (let f ((exports exports))
+ (if (null? exports)
+ '()
+ (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
+ (flatten-exports (cdar exports))
+ (f (cdr exports)))))))
+ (define update-imp-exports
+ (lambda (bindings exports)
+ (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
+ (map (lambda (b)
+ (let ((id (module-binding-id b)))
+ (if (not (bound-id-member? id exports))
+ b
+ (make-module-binding
+ (module-binding-type b)
+ id
+ (module-binding-label b)
+ (append (get-implicit-exports id) (module-binding-imps b))
+ (module-binding-val b)))))
+ bindings))))
+ (let parse ((body body) (ids '()) (bindings '()) (inits '()))
+ (if (null? body)
+ (return bindings ids inits)
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda () (syntax-type e er empty-wrap no-source ribcage))
+ (lambda (type value e w s)
+ (case type
+ ((define-form)
+ (parse-define e w s
+ (lambda (id rhs w)
+ (let* ((id (wrap id w))
+ (label (gen-indirect-label))
+ (imps (get-implicit-exports id)))
+ (extend-ribcage! ribcage id label)
+ (parse
+ (cdr body)
+ (cons id ids)
+ (cons (make-module-binding type id label
+ imps (cons er (wrap rhs w)))
+ bindings)
+ inits)))))
+ ((define-syntax-form)
+ (parse-define-syntax e w s
+ (lambda (id rhs w)
+ (let* ((id (wrap id w))
+ (label (gen-indirect-label))
+ (imps (get-implicit-exports id))
+ (exp (chi rhs (transformer-env er) w)))
+ ; arrange to evaluate the transformer lazily
+ (extend-store! r (get-indirect-label label) (cons 'deferred exp))
+ (extend-ribcage! ribcage id label)
+ (parse
+ (cdr body)
+ (cons id ids)
+ (cons (make-module-binding type id label imps exp)
+ bindings)
+ inits)))))
+ ((module-form)
+ (let* ((*ribcage (make-empty-ribcage))
+ (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
+ (parse-module e w s *w
+ (lambda (id *exports forms)
+ (chi-external *ribcage (source-wrap e w s)
+ (map (lambda (d) (cons er d)) forms)
+ r *exports (flatten-exports *exports) m esew
+ (lambda (*bindings *inits)
+ (let* ((iface (make-trimmed-interface *exports))
+ (bindings (append (if id *bindings (update-imp-exports *bindings *exports)) bindings))
+ (inits (append inits *inits)))
+ (if id
+ (let ((label (gen-indirect-label))
+ (imps (get-implicit-exports id)))
+ (extend-store! r (get-indirect-label label)
+ (make-binding 'module iface))
+ (extend-ribcage! ribcage id label)
+ (parse
+ (cdr body)
+ (cons id ids)
+ (cons (make-module-binding type id label imps *exports) bindings)
+ inits))
+ (let ()
+ (do-import! iface ribcage)
+ (parse (cdr body) (cons iface ids) bindings inits))))))))))
+ ((import-form)
+ (parse-import e w s
+ (lambda (mid)
+ (let ((mlabel (id-var-name mid empty-wrap)))
+ (let ((binding (lookup mlabel r)))
+ (case (binding-type binding)
+ ((module)
+ (let ((iface (binding-value binding)))
+ (when value (extend-ribcage-barrier! ribcage value))
+ (do-import! iface ribcage)
+ (parse
+ (cdr body)
+ (cons iface ids)
+ (update-imp-exports bindings (vector->list (interface-exports iface)))
+ inits)))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "import from unknown module"))))))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse (let f ((forms (syntax (e1 ...))))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids bindings inits))))
+ ((local-syntax-form)
+ (chi-local-syntax value e er w s
+ (lambda (forms er w s)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids bindings inits))))
+ (else ; found an init expression
+ (return bindings ids
+ (append inits (cons (cons er (source-wrap e w s)) (cdr body)))))))))))))
+
+(define vmap
+ (lambda (fn v)
+ (do ((i (fx- (vector-length v) 1) (fx- i 1))
+ (ls '() (cons (fn (vector-ref v i)) ls)))
+ ((fx< i 0) ls))))
+
+(define vfor-each
+ (lambda (fn v)
+ (let ((len (vector-length v)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (fn (vector-ref v i))))))
+
+(define do-top-import
+ (lambda (mid token)
+ (build-cte-install mid
+ (build-data no-source
+ (make-binding 'do-import token)))))
+
+(define ct-eval/residualize
+ (lambda (m esew thunk)
+ (case m
+ ((c) (if (memq 'compile esew)
+ (let ((e (thunk)))
+ (top-level-eval-hook e)
+ (if (memq 'load esew) e (chi-void)))
+ (if (memq 'load esew) (thunk) (chi-void))))
+ ((c&e) (let ((e (thunk))) (top-level-eval-hook e) e))
+ (else (if (memq 'eval esew) (top-level-eval-hook (thunk))) (chi-void)))))
+
+(define chi
+ (lambda (e r w)
+ (call-with-values
+ (lambda () (syntax-type e r w no-source #f))
+ (lambda (type value e w s)
+ (chi-expr type value e r w s)))))
+
+(define chi-expr
+ (lambda (type value e r w s)
+ (case type
+ ((lexical)
+ (build-lexical-reference 'value s value))
+ ((core) (value e r w s))
+ ((lexical-call)
+ (chi-application
+ (build-lexical-reference 'fun (source-annotation (car e)) value)
+ e r w s))
+ ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
+ ((global) (build-global-reference s value))
+ ((call) (chi-application (chi (car e) r w) e r w s))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s chi-sequence))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e (syntax (x ...)) w)))
+ (if (memq 'eval when-list)
+ (chi-sequence (syntax (e1 e2 ...)) r w s)
+ (chi-void))))))
+ ((define-form define-syntax-form module-form import-form)
+ (syntax-error (source-wrap e w s) "invalid context for definition"))
+ ((syntax)
+ (syntax-error (source-wrap e w s)
+ "reference to pattern variable outside syntax form"))
+ ((displaced-lexical) (displaced-lexical-error (source-wrap e w s)))
+ (else (syntax-error (source-wrap e w s))))))
+
+(define chi-application
+ (lambda (x e r w s)
+ (syntax-case e ()
+ ((e0 e1 ...)
+ (build-application s x
+ (map (lambda (e) (chi e r w)) (syntax (e1 ...)))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define chi-set!
+ (lambda (e r w s rib)
+ (syntax-case e ()
+ ((_ id val)
+ (id? (syntax id))
+ (let ((n (id-var-name (syntax id) w)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((macro!)
+ (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
+ (syntax-type (chi-macro (binding-value b)
+ `(,(syntax set!) ,id ,val)
+ r empty-wrap s rib) r empty-wrap s rib)))
+ (else
+ (values 'core
+ (lambda (e r w s)
+ ; repeat lookup in case we were first expression (init) in
+ ; module or lambda body. we repeat id-var-name as well,
+ ; although this is only necessary if we allow inits to
+ ; preced definitions
+ (let ((val (chi (syntax val) r w))
+ (n (id-var-name (syntax id) w)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((lexical) (build-lexical-assignment s (binding-value b) val))
+ ((global) (build-global-assignment s (binding-value b) val))
+ ((displaced-lexical)
+ (syntax-error (wrap (syntax id) w) "identifier out of context"))
+ (else (syntax-error (source-wrap e w s)))))))
+ e w s))))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define chi-macro
+ (lambda (p e r w s rib)
+ (define rebuild-macro-output
+ (lambda (x m)
+ (cond ((pair? x)
+ (cons (rebuild-macro-output (car x) m)
+ (rebuild-macro-output (cdr x) m)))
+ ((syntax-object? x)
+ (let ((w (syntax-object-wrap x)))
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (make-syntax-object (syntax-object-expression x)
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ (make-wrap (cdr ms)
+ (if rib (cons rib (cdr s)) (cdr s)))
+ (make-wrap (cons m ms)
+ (if rib
+ (cons rib (cons 'shift s))
+ (cons 'shift s))))))))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i n) v)
+ (vector-set! v i
+ (rebuild-macro-output (vector-ref x i) m)))))
+ ((symbol? x)
+ (syntax-error (source-wrap e w s)
+ "encountered raw symbol "
+ (format "~s" x)
+ " in output of macro"))
+ (else x))))
+ (rebuild-macro-output
+ (let ((out (p (source-wrap e (anti-mark w) s))))
+ (if (procedure? out)
+ (out (lambda (id)
+ (unless (identifier? id)
+ (syntax-error id
+ "environment argument is not an identifier"))
+ (lookup (id-var-name id empty-wrap) r)))
+ out))
+ (new-mark))))
+
+(define chi-body
+ ;; Here we create the empty wrap and new environment with placeholder
+ ;; as required by chi-internal. On return we extend the environment
+ ;; to recognize the var-labels as lexical variables and build a letrec
+ ;; binding them to the var-vals which we expand here.
+ (lambda (body outer-form r w)
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
+ (body (map (lambda (x) (cons r (wrap x w))) body)))
+ (chi-internal ribcage outer-form body r
+ (lambda (exprs ids vars vals inits)
+ (when (null? exprs) (syntax-error outer-form "no expressions in body"))
+ (build-letrec no-source
+ vars
+ (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) vals)
+ (build-sequence no-source
+ (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) (append inits exprs)))))))))
+
+(define chi-internal
+ ;; In processing the forms of the body, we create a new, empty wrap.
+ ;; This wrap is augmented (destructively) each time we discover that
+ ;; the next form is a definition. This is done:
+ ;;
+ ;; (1) to allow the first nondefinition form to be a call to
+ ;; one of the defined ids even if the id previously denoted a
+ ;; definition keyword or keyword for a macro expanding into a
+ ;; definition;
+ ;; (2) to prevent subsequent definition forms (but unfortunately
+ ;; not earlier ones) and the first nondefinition form from
+ ;; confusing one of the bound identifiers for an auxiliary
+ ;; keyword; and
+ ;; (3) so that we do not need to restart the expansion of the
+ ;; first nondefinition form, which is problematic anyway
+ ;; since it might be the first element of a begin that we
+ ;; have just spliced into the body (meaning if we restarted,
+ ;; we'd really need to restart with the begin or the macro
+ ;; call that expanded into the begin, and we'd have to give
+ ;; up allowing (begin <defn>+ <expr>+), which is itself
+ ;; problematic since we don't know if a begin contains only
+ ;; definitions until we've expanded it).
+ ;;
+ ;; Before processing the body, we also create a new environment
+ ;; containing a placeholder for the bindings we will add later and
+ ;; associate this environment with each form. In processing a
+ ;; let-syntax or letrec-syntax, the associated environment may be
+ ;; augmented with local keyword bindings, so the environment may
+ ;; be different for different forms in the body. Once we have
+ ;; gathered up all of the definitions, we evaluate the transformer
+ ;; expressions and splice into r at the placeholder the new variable
+ ;; and keyword bindings. This allows let-syntax or letrec-syntax
+ ;; forms local to a portion or all of the body to shadow the
+ ;; definition bindings.
+ ;;
+ ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
+ ;; into the body.
+ ;;
+ ;; outer-form is fully wrapped w/source
+ (lambda (ribcage source-exp body r k)
+ (define return
+ (lambda (exprs ids vars vals inits)
+ (check-defined-ids source-exp ids)
+ (k exprs ids vars vals inits)))
+ (let parse ((body body) (ids '()) (vars '()) (vals '()) (inits '()))
+ (if (null? body)
+ (return body ids vars vals inits)
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda () (syntax-type e er empty-wrap no-source ribcage))
+ (lambda (type value e w s)
+ (case type
+ ((define-form)
+ (parse-define e w s
+ (lambda (id rhs w)
+ (let ((id (wrap id w)) (label (gen-label)))
+ (let ((var (gen-var id)))
+ (extend-ribcage! ribcage id label)
+ (extend-store! r label (make-binding 'lexical var))
+ (parse
+ (cdr body)
+ (cons id ids)
+ (cons var vars)
+ (cons (cons er (wrap rhs w)) vals)
+ inits))))))
+ ((define-syntax-form)
+ (parse-define-syntax e w s
+ (lambda (id rhs w)
+ (let ((id (wrap id w))
+ (label (gen-label))
+ (exp (chi rhs (transformer-env er) w)))
+ (extend-ribcage! ribcage id label)
+ (extend-store! r label (make-binding 'deferred exp))
+ (parse (cdr body) (cons id ids) vars vals inits)))))
+ ((module-form)
+ (let* ((*ribcage (make-empty-ribcage))
+ (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
+ (parse-module e w s *w
+ (lambda (id exports forms)
+ (chi-internal *ribcage (source-wrap e w s)
+ (map (lambda (d) (cons er d)) forms) r
+ (lambda (*body *ids *vars *vals *inits)
+ ; valid bound ids checked already by chi-internal
+ (check-module-exports source-exp (flatten-exports exports) *ids)
+ (let ((iface (make-trimmed-interface exports))
+ (vars (append *vars vars))
+ (vals (append *vals vals))
+ (inits (append inits *inits *body)))
+ (if id
+ (let ((label (gen-label)))
+ (extend-ribcage! ribcage id label)
+ (extend-store! r label (make-binding 'module iface))
+ (parse (cdr body) (cons id ids) vars vals inits))
+ (let ()
+ (do-import! iface ribcage)
+ (parse (cdr body) (cons iface ids) vars vals inits))))))))))
+ ((import-form)
+ (parse-import e w s
+ (lambda (mid)
+ (let ((mlabel (id-var-name mid empty-wrap)))
+ (let ((binding (lookup mlabel r)))
+ (case (car binding)
+ ((module)
+ (let ((iface (cdr binding)))
+ (when value (extend-ribcage-barrier! ribcage value))
+ (do-import! iface ribcage)
+ (parse (cdr body) (cons iface ids) vars vals inits)))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "import from unknown module"))))))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse (let f ((forms (syntax (e1 ...))))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids vars vals inits))))
+ ((local-syntax-form)
+ (chi-local-syntax value e er w s
+ (lambda (forms er w s)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids vars vals inits))))
+ (else ; found a non-definition
+ (return (cons (cons er (source-wrap e w s)) (cdr body))
+ ids vars vals inits))))))))))
+
+(define do-import!
+ (lambda (interface ribcage)
+ (let ((token (interface-token interface)))
+ (if token
+ (extend-ribcage-subst! ribcage token)
+ (vfor-each
+ (lambda (id)
+ (let ((label1 (id-var-name-loc id empty-wrap)))
+ (unless label1
+ (syntax-error id "exported identifier not visible"))
+ (extend-ribcage! ribcage id label1)))
+ (interface-exports interface))))))
+
+(define parse-module
+ (lambda (e w s *w k)
+ (define listify
+ (lambda (exports)
+ (if (null? exports)
+ '()
+ (cons (syntax-case (car exports) ()
+ ((ex ...) (listify (syntax (ex ...))))
+ (x (if (id? (syntax x))
+ (wrap (syntax x) *w)
+ (syntax-error (source-wrap e w s)
+ "invalid exports list in"))))
+ (listify (cdr exports))))))
+ (define return
+ (lambda (id exports forms)
+ (k id (listify exports) (map (lambda (x) (wrap x *w)) forms))))
+ (syntax-case e ()
+ ((_ (ex ...) form ...)
+ (return #f (syntax (ex ...)) (syntax (form ...))))
+ ((_ mid (ex ...) form ...)
+ (id? (syntax mid))
+ ; id receives old wrap so it won't be confused with id of same name
+ ; defined within the module
+ (return (wrap (syntax mid) w) (syntax (ex ...)) (syntax (form ...))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define parse-import
+ (lambda (e w s k)
+ (syntax-case e ()
+ ((_ mid)
+ (id? (syntax mid))
+ (k (wrap (syntax mid) w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define parse-define
+ (lambda (e w s k)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (k (syntax name) (syntax val) w))
+ ((_ (name . args) e1 e2 ...)
+ (and (id? (syntax name))
+ (valid-bound-ids? (lambda-var-list (syntax args))))
+ (k (wrap (syntax name) w)
+ (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
+ empty-wrap))
+ ((_ name)
+ (id? (syntax name))
+ (k (wrap (syntax name) w) (syntax (void)) empty-wrap))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define parse-define-syntax
+ (lambda (e w s k)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (k (syntax name) (syntax val) w))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define chi-lambda-clause
+ (lambda (e c r w k)
+ (syntax-case c ()
+ (((id ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (syntax-error e "invalid parameter list in")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (k new-vars
+ (chi-body (syntax (e1 e2 ...))
+ e
+ (extend-var-env* labels new-vars r)
+ (make-binding-wrap ids labels w)))))))
+ ((ids e1 e2 ...)
+ (let ((old-ids (lambda-var-list (syntax ids))))
+ (if (not (valid-bound-ids? old-ids))
+ (syntax-error e "invalid parameter list in")
+ (let ((labels (gen-labels old-ids))
+ (new-vars (map gen-var old-ids)))
+ (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
+ (if (null? ls1)
+ ls2
+ (f (cdr ls1) (cons (car ls1) ls2))))
+ (chi-body (syntax (e1 e2 ...))
+ e
+ (extend-var-env* labels new-vars r)
+ (make-binding-wrap old-ids labels w)))))))
+ (_ (syntax-error e)))))
+
+(define chi-local-syntax
+ (lambda (rec? e r w s k)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
+ (source-wrap e w s)
+ "keyword")
+ (let ((labels (gen-labels ids)))
+ (let ((new-w (make-binding-wrap ids labels w)))
+ (k (syntax (e1 e2 ...))
+ (extend-env*
+ labels
+ (let ((w (if rec? new-w w))
+ (trans-r (transformer-env r)))
+ (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
+ r)
+ new-w
+ s))))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define chi-void
+ (lambda ()
+ (build-application no-source (build-primref no-source 'void) '())))
+
+(define ellipsis?
+ (lambda (x)
+ (and (nonsymbol-id? x)
+ (literal-id=? x (syntax (... ...))))))
+
+;;; data
+
+;;; strips all annotations from potentially circular reader output
+
+(define strip-annotation
+ (lambda (x parent)
+ (cond
+ ((pair? x)
+ (let ((new (cons #f #f)))
+ (when parent (set-annotation-stripped! parent new))
+ (set-car! new (strip-annotation (car x) #f))
+ (set-cdr! new (strip-annotation (cdr x) #f))
+ new))
+ ((annotation? x)
+ (or (annotation-stripped x)
+ (strip-annotation (annotation-expression x) x)))
+ ((vector? x)
+ (let ((new (make-vector (vector-length x))))
+ (when parent (set-annotation-stripped! parent new))
+ (let loop ((i (- (vector-length x) 1)))
+ (unless (fx< i 0)
+ (vector-set! new i (strip-annotation (vector-ref x i) #f))
+ (loop (fx- i 1))))
+ new))
+ (else x))))
+
+;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
+;;; on an annotation, strips the annotation as well.
+;;; since only the head of a list is annotated by the reader, not each pair
+;;; in the spine, we also check for pairs whose cars are annotated in case
+;;; we've been passed the cdr of an annotated list
+
+(define strip*
+ (lambda (x w fn)
+ (if (top-marked? w)
+ (fn x)
+ (let f ((x x))
+ (cond
+ ((syntax-object? x)
+ (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x)))
+ x
+ (cons a d))))
+ ((vector? x)
+ (let ((old (vector->list x)))
+ (let ((new (map f old)))
+ (if (andmap eq? old new) x (list->vector new)))))
+ (else x))))))
+
+(define strip
+ (lambda (x w)
+ (strip* x w
+ (lambda (x)
+ (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
+ (strip-annotation x #f)
+ x)))))
+
+;;; lexical variables
+
+(define gen-var
+ (lambda (id)
+ (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (if (annotation? id)
+ (build-lexical-var (annotation-source id) (annotation-expression id))
+ (build-lexical-var no-source id)))))
+
+(define lambda-var-list
+ (lambda (vars)
+ (let lvl ((vars vars) (ls '()) (w empty-wrap))
+ (cond
+ ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
+ ((id? vars) (cons (wrap vars w) ls))
+ ((null? vars) ls)
+ ((syntax-object? vars)
+ (lvl (syntax-object-expression vars)
+ ls
+ (join-wraps w (syntax-object-wrap vars))))
+ ((annotation? vars)
+ (lvl (annotation-expression vars) ls w))
+ ; include anything else to be caught by subsequent error
+ ; checking
+ (else (cons vars ls))))))
+
+
+; must precede global-extends
+
+(set! $sc-put-cte
+ (lambda (id b)
+ (define put-token
+ (lambda (id token)
+ (define cons-id
+ (lambda (id x)
+ (if (not x) id (cons id x))))
+ (define weed
+ (lambda (id x)
+ (if (pair? x)
+ (if (bound-id=? (car x) id) ; could just check same-marks
+ (weed id (cdr x))
+ (cons-id (car x) (weed id (cdr x))))
+ (if (or (not x) (bound-id=? x id))
+ #f
+ x))))
+ (let ((sym (id-sym-name id)))
+ (let ((x (weed id (getprop sym token))))
+ (if (and (not x) (symbol? id))
+ ; don't pollute property list when all we have is a plain
+ ; top-level binding, since that's what's assumed anyway
+ (remprop sym token)
+ (putprop sym token (cons-id id x)))))))
+ (define sc-put-module
+ (lambda (exports token)
+ (vfor-each
+ (lambda (id) (put-token id token))
+ exports)))
+ (define (put-cte id binding)
+ ;; making assumption here that all macros should be visible to the user and that system
+ ;; globals don't come through here (primvars.ss sets up their properties)
+ (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
+ (putprop sym '*sc-expander* binding)))
+ (let ((binding (or (sanitize-binding b) (error 'define-syntax "invalid transformer ~s" b))))
+ (case (binding-type binding)
+ ((module)
+ (let ((iface (binding-value binding)))
+ (sc-put-module (interface-exports iface) (interface-token iface)))
+ (put-cte id binding))
+ ((do-import) ; fake binding: id is module id, binding-value is import token
+ (let ((token (binding-value b)))
+ (let ((b (lookup (id-var-name id empty-wrap) null-env)))
+ (case (binding-type b)
+ ((module)
+ (let ((iface (binding-value b)))
+ (unless (eq? (interface-token iface) token)
+ (syntax-error id "import mismatch for module"))
+ (sc-put-module (interface-exports iface) '*top*)))
+ (else (syntax-error id "import from unknown module"))))))
+ (else (put-cte id binding))))))
+
+
+;;; core transformers
+
+(global-extend 'local-syntax 'letrec-syntax #t)
+(global-extend 'local-syntax 'let-syntax #f)
+
+
+(global-extend 'core 'fluid-let-syntax
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? (syntax (var ...)))
+ (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
+ (for-each
+ (lambda (id n)
+ (case (binding-type (lookup n r))
+ ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
+ (syntax (var ...))
+ names)
+ (chi-body
+ (syntax (e1 e2 ...))
+ (source-wrap e w s)
+ (extend-env*
+ names
+ (let ((trans-r (transformer-env r)))
+ (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
+ r)
+ w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'core 'quote
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ e) (build-data s (strip (syntax e) w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis?)
+ (if (id? e)
+ (let ((label (id-var-name e empty-wrap)))
+ (let ((b (lookup label r)))
+ (if (eq? (binding-type b) 'syntax)
+ (call-with-values
+ (lambda ()
+ (let ((var.lev (binding-value b)))
+ (gen-ref src (car var.lev) (cdr var.lev) maps)))
+ (lambda (var maps) (values `(ref ,var) maps)))
+ (if (ellipsis? e)
+ (syntax-error src "misplaced ellipsis in syntax form")
+ (values `(quote ,e) maps)))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? (syntax dots))
+ (gen-syntax src (syntax e) r maps (lambda (x) #f)))
+ ((x dots . y)
+ ; this could be about a dozen lines of code, except that we
+ ; choose to handle (syntax (x ... ...)) forms
+ (ellipsis? (syntax dots))
+ (let f ((y (syntax y))
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src (syntax x) r
+ (cons '() maps) ellipsis?))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-error src
+ "extra ellipsis in syntax form")
+ (values (gen-map x (car maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? (syntax dots))
+ (f (syntax y)
+ (lambda (maps)
+ (call-with-values
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-error src
+ "extra ellipsis in syntax form")
+ (values (gen-mappend x (car maps))
+ (cdr maps))))))))
+ (_ (call-with-values
+ (lambda () (gen-syntax src y r maps ellipsis?))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps)
+ (values (gen-append x y) maps)))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
+ (lambda (y maps) (values (gen-cons x y) maps))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-error src "missing ellipsis in syntax form")
+ (call-with-values
+ (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var inner-var)
+ (car maps))
+ outer-maps)))))))))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ; identity map equivalence:
+ ; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((andmap
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ; eta map equivalence:
+ ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ (define gen-cons
+ (lambda (x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y)))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-vector
+ (lambda (x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x)))))
+
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
+ ((map) (let ((ls (map regen (cdr x))))
+ (build-application no-source
+ (if (fx= (length ls) 2)
+ (build-primref no-source 'map)
+ ; really need to do our own checking here
+ (build-primref no-source 2 'map)) ; require error check
+ ls)))
+ (else (build-application no-source
+ (build-primref no-source (car x))
+ (map regen (cdr x)))))))
+
+ (lambda (e r w s)
+ (let ((e (source-wrap e w s)))
+ (syntax-case e ()
+ ((_ x)
+ (call-with-values
+ (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-error e)))))))
+
+
+(global-extend 'core 'lambda
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ . c)
+ (chi-lambda-clause (source-wrap e w s) (syntax c) r w
+ (lambda (vars body) (build-lambda s vars body)))))))
+
+
+(global-extend 'core 'letrec
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
+ (source-wrap e w s) "bound variable")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((w (make-binding-wrap ids labels w))
+ (r (extend-var-env* labels new-vars r)))
+ (build-letrec s
+ new-vars
+ (map (lambda (x) (chi x r w)) (syntax (val ...)))
+ (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'core 'if
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional s
+ (chi (syntax test) r w)
+ (chi (syntax then) r w)
+ (chi-void)))
+ ((_ test then else)
+ (build-conditional s
+ (chi (syntax test) r w)
+ (chi (syntax then) r w)
+ (chi (syntax else) r w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+
+
+(global-extend 'set! 'set! '())
+
+(global-extend 'begin 'begin '())
+
+(global-extend 'module-key 'module '())
+(global-extend 'import 'import #f)
+(global-extend 'import 'import-only #t)
+
+(global-extend 'define 'define '())
+
+(global-extend 'define-syntax 'define-syntax '())
+
+(global-extend 'eval-when 'eval-when '())
+
+(global-extend 'core 'syntax-case
+ (let ()
+ (define convert-pattern
+ ; accepts pattern & keys
+ ; returns syntax-dispatch pattern & ids
+ (lambda (pattern keys)
+ (let cvt ((p pattern) (n 0) (ids '()))
+ (if (id? p)
+ (if (bound-id-member? p keys)
+ (values (vector 'free-id p) ids)
+ (values 'any (cons (cons p n) ids)))
+ (syntax-case p ()
+ ((x dots)
+ (ellipsis? (syntax dots))
+ (call-with-values
+ (lambda () (cvt (syntax x) (fx+ n 1) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any (vector 'each p))
+ ids))))
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt (syntax y) n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt (syntax x) n ids))
+ (lambda (x ids)
+ (values (cons x y) ids))))))
+ (() (values '() ids))
+ (#(x ...)
+ (call-with-values
+ (lambda () (cvt (syntax (x ...)) n ids))
+ (lambda (p ids) (values (vector 'vector p) ids))))
+ (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
+
+ (define build-dispatch-call
+ (lambda (pvars exp y r)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (build-application no-source
+ (build-primref no-source 'apply)
+ (list (build-lambda no-source new-vars
+ (chi exp
+ (extend-env*
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)))
+ y))))))
+
+ (define gen-clause
+ (lambda (x keys clauses r pat fender exp)
+ (call-with-values
+ (lambda () (convert-pattern pat keys))
+ (lambda (p pvars)
+ (cond
+ ((not (distinct-bound-ids? (map car pvars)))
+ (invalid-ids-error (map car pvars) pat "pattern variable"))
+ ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (syntax-error pat
+ "misplaced ellipsis in syntax-case pattern"))
+ (else
+ (let ((y (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable y
+ (build-application no-source
+ (build-lambda no-source (list y)
+ (let-syntax ((y (identifier-syntax
+ (build-lexical-reference 'value no-source y))))
+ (build-conditional no-source
+ (syntax-case fender ()
+ (#t y)
+ (_ (build-conditional no-source
+ y
+ (build-dispatch-call pvars fender y r)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r)
+ (gen-syntax-case x keys clauses r))))
+ (list (if (eq? p 'any)
+ (build-application no-source
+ (build-primref no-source 'list)
+ (list (build-lexical-reference no-source 'value x)))
+ (build-application no-source
+ (build-primref no-source '$syntax-dispatch)
+ (list (build-lexical-reference no-source 'value x)
+ (build-data no-source p)))))))))))))
+
+ (define gen-syntax-case
+ (lambda (x keys clauses r)
+ (if (null? clauses)
+ (build-application no-source
+ (build-primref no-source 'syntax-error)
+ (list (build-lexical-reference 'value no-source x)))
+ (syntax-case (car clauses) ()
+ ((pat exp)
+ (if (and (id? (syntax pat))
+ (not (bound-id-member? (syntax pat) keys))
+ (not (ellipsis? (syntax pat))))
+ (let ((label (gen-label))
+ (var (gen-var (syntax pat))))
+ (build-application no-source
+ (build-lambda no-source (list var)
+ (chi (syntax exp)
+ (extend-env label (make-binding 'syntax `(,var . 0)) r)
+ (make-binding-wrap (syntax (pat))
+ (list label) empty-wrap)))
+ (list (build-lexical-reference 'value no-source x))))
+ (gen-clause x keys (cdr clauses) r
+ (syntax pat) #t (syntax exp))))
+ ((pat fender exp)
+ (gen-clause x keys (cdr clauses) r
+ (syntax pat) (syntax fender) (syntax exp)))
+ (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+
+ (lambda (e r w s)
+ (let ((e (source-wrap e w s)))
+ (syntax-case e ()
+ ((_ val (key ...) m ...)
+ (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
+ (syntax (key ...)))
+ (let ((x (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable x
+ (build-application s
+ (build-lambda no-source (list x)
+ (gen-syntax-case x
+ (syntax (key ...)) (syntax (m ...))
+ r))
+ (list (chi (syntax val) r empty-wrap))))
+ (syntax-error e "invalid literals list in"))))))))
+
+;;; The portable sc-expand seeds chi-top's mode m with 'e (for
+;;; evaluating) and esew (which stands for "eval syntax expanders
+;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
+;;; if we are compiling a file, and esew is set to
+;;; (eval-syntactic-expanders-when), which defaults to the list
+;;; '(compile load eval). This means that, by default, top-level
+;;; syntactic definitions are evaluated immediately after they are
+;;; expanded, and the expanded definitions are also residualized into
+;;; the object file if we are compiling a file.
+(set! sc-expand
+ (let ((m 'e) (esew '(eval))
+ (user-ribcage
+ (let ((ribcage (make-empty-ribcage)))
+ (extend-ribcage-subst! ribcage '*top*)
+ ribcage)))
+ (let ((user-top-wrap
+ (make-wrap (wrap-marks top-wrap)
+ (cons user-ribcage (wrap-subst top-wrap)))))
+ (lambda (x)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (chi-top x null-env user-top-wrap m esew user-ribcage))))))
+
+(set! identifier?
+ (lambda (x)
+ (nonsymbol-id? x)))
+
+(set! datum->syntax-object
+ (lambda (id datum)
+ (arg-check nonsymbol-id? id 'datum->syntax-object)
+ (make-syntax-object datum (syntax-object-wrap id))))
+
+(set! syntax-object->datum
+ ; accepts any object, since syntax objects may consist partially
+ ; or entirely of unwrapped, nonsymbolic data
+ (lambda (x)
+ (strip x empty-wrap)))
+
+(set! generate-temporaries
+ (lambda (ls)
+ (arg-check list? ls 'generate-temporaries)
+ (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
+
+(set! free-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'free-identifier=?)
+ (arg-check nonsymbol-id? y 'free-identifier=?)
+ (free-id=? x y)))
+
+(set! bound-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'bound-identifier=?)
+ (arg-check nonsymbol-id? y 'bound-identifier=?)
+ (bound-id=? x y)))
+
+
+(set! syntax-error
+ (lambda (object . messages)
+ (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
+ (let ((message (if (null? messages)
+ "invalid syntax"
+ (apply string-append messages))))
+ (error-hook #f message (strip object empty-wrap)))))
+
+;;; syntax-dispatch expects an expression and a pattern. If the expression
+;;; matches the pattern a list of the matching expressions for each
+;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
+;;; not work on r4rs implementations that violate the ieee requirement
+;;; that #f and () be distinct.)
+
+;;; The expression is matched with the pattern as follows:
+
+;;; pattern: matches:
+;;; () empty list
+;;; any anything
+;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
+;;; each-any (any*)
+;;; #(free-id <key>) <key> with free-identifier=?
+;;; #(each <pattern>) (<pattern>*)
+;;; #(vector <pattern>) (list->vector <pattern>)
+;;; #(atom <object>) <object> with "equal?"
+
+;;; Vector cops out to pair under assumption that vectors are rare. If
+;;; not, should convert to:
+;;; #(vector <pattern>*) #(<pattern>*)
+
+(let ()
+
+(define match-each
+ (lambda (e p w)
+ (cond
+ ((annotation? e)
+ (match-each (annotation-expression e) p w))
+ ((pair? e)
+ (let ((first (match (car e) p w '())))
+ (and first
+ (let ((rest (match-each (cdr e) p w)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))))
+ (else #f))))
+
+(define match-each-any
+ (lambda (e w)
+ (cond
+ ((annotation? e)
+ (match-each-any (annotation-expression e) w))
+ ((pair? e)
+ (let ((l (match-each-any (cdr e) w)))
+ (and l (cons (wrap (car e) w) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))))
+ (else #f))))
+
+(define match-empty
+ (lambda (p r)
+ (cond
+ ((null? p) r)
+ ((eq? p 'any) (cons '() r))
+ ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+ ((eq? p 'each-any) (cons '() r))
+ (else
+ (case (vector-ref p 0)
+ ((each) (match-empty (vector-ref p 1) r))
+ ((free-id atom) r)
+ ((vector) (match-empty (vector-ref p 1) r)))))))
+
+(define match*
+ (lambda (e p w r)
+ (cond
+ ((null? p) (and (null? e) r))
+ ((pair? p)
+ (and (pair? e) (match (car e) (car p) w
+ (match (cdr e) (cdr p) w r))))
+ ((eq? p 'each-any)
+ (let ((l (match-each-any e w))) (and l (cons l r))))
+ (else
+ (case (vector-ref p 0)
+ ((each)
+ (if (null? e)
+ (match-empty (vector-ref p 1) r)
+ (let ((l (match-each e (vector-ref p 1) w)))
+ (and l
+ (let collect ((l l))
+ (if (null? (car l))
+ r
+ (cons (map car l) (collect (map cdr l)))))))))
+ ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
+ ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
+ ((vector)
+ (and (vector? e)
+ (match (vector->list e) (vector-ref p 1) w r))))))))
+
+(define match
+ (lambda (e p w r)
+ (cond
+ ((not r) #f)
+ ((eq? p 'any) (cons (wrap e w) r))
+ ((syntax-object? e)
+ (match*
+ (unannotate (syntax-object-expression e))
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r))
+ (else (match* (unannotate e) p w r)))))
+
+(set! $syntax-dispatch
+ (lambda (e p)
+ (cond
+ ((eq? p 'any) (list e))
+ ((syntax-object? e)
+ (match* (unannotate (syntax-object-expression e))
+ p (syntax-object-wrap e) '()))
+ (else (match* (unannotate e) p empty-wrap '())))))
+))
+
+
+(define-syntax with-syntax
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () e1 e2 ...)
+ (syntax (begin e1 e2 ...)))
+ ((_ ((out in)) e1 e2 ...)
+ (syntax (syntax-case in () (out (begin e1 e2 ...)))))
+ ((_ ((out in) ...) e1 e2 ...)
+ (syntax (syntax-case (list in ...) ()
+ ((out ...) (begin e1 e2 ...))))))))
+
+(define-syntax syntax-rules
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k ...) ((keyword . pattern) template) ...)
+ (syntax (lambda (x)
+ (syntax-case x (k ...)
+ ((dummy . pattern) (syntax template))
+ ...)))))))
+
+(define-syntax or
+ (lambda (x)
+ (syntax-case x ()
+ ((_) (syntax #f))
+ ((_ e) (syntax e))
+ ((_ e1 e2 e3 ...)
+ (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
+
+(define-syntax and
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
+ ((_ e) (syntax e))
+ ((_) (syntax #t)))))
+
+(define-syntax let
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (x ...)))
+ (syntax ((lambda (x ...) e1 e2 ...) v ...)))
+ ((_ f ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (f x ...)))
+ (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
+ v ...))))))
+
+(define-syntax let*
+ (lambda (x)
+ (syntax-case x ()
+ ((let* ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (x ...)))
+ (let f ((bindings (syntax ((x v) ...))))
+ (if (null? bindings)
+ (syntax (let () e1 e2 ...))
+ (with-syntax ((body (f (cdr bindings)))
+ (binding (car bindings)))
+ (syntax (let (binding) body)))))))))
+
+(define-syntax cond
+ (lambda (x)
+ (syntax-case x ()
+ ((_ m1 m2 ...)
+ (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
+ (if (null? clauses)
+ (syntax-case clause (else =>)
+ ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
+ ((e0) (syntax (let ((t e0)) (if t t))))
+ ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
+ ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
+ (_ (syntax-error x)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else =>)
+ ((e0) (syntax (let ((t e0)) (if t t rest))))
+ ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
+ ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
+ (_ (syntax-error x))))))))))
+
+(define-syntax do
+ (lambda (orig-x)
+ (syntax-case orig-x ()
+ ((_ ((var init . step) ...) (e0 e1 ...) c ...)
+ (with-syntax (((step ...)
+ (map (lambda (v s)
+ (syntax-case s ()
+ (() v)
+ ((e) (syntax e))
+ (_ (syntax-error orig-x))))
+ (syntax (var ...))
+ (syntax (step ...)))))
+ (syntax-case (syntax (e1 ...)) ()
+ (() (syntax (let doloop ((var init) ...)
+ (if (not e0)
+ (begin c ... (doloop step ...))))))
+ ((e1 e2 ...)
+ (syntax (let doloop ((var init) ...)
+ (if e0
+ (begin e1 e2 ...)
+ (begin c ... (doloop step ...))))))))))))
+
+(define-syntax quasiquote
+ (letrec
+ ; these are here because syntax-case uses literal-identifier=?,
+ ; and we want the more precise free-identifier=?
+ ((isquote? (lambda (x)
+ (and (identifier? x)
+ (free-identifier=? x (syntax quote)))))
+ (islist? (lambda (x)
+ (and (identifier? x)
+ (free-identifier=? x (syntax list)))))
+ (iscons? (lambda (x)
+ (and (identifier? x)
+ (free-identifier=? x (syntax cons)))))
+ (quote-nil? (lambda (x)
+ (syntax-case x ()
+ ((quote? ()) (isquote? (syntax quote?)))
+ (_ #f))))
+ (quasilist*
+ (lambda (x y)
+ (let f ((x x))
+ (if (null? x)
+ y
+ (quasicons (car x) (f (cdr x)))))))
+ (quasicons
+ (lambda (x y)
+ (with-syntax ((x x) (y y))
+ (syntax-case (syntax y) ()
+ ((quote? dy)
+ (isquote? (syntax quote?))
+ (syntax-case (syntax x) ()
+ ((quote? dx)
+ (isquote? (syntax quote?))
+ (syntax (quote (dx . dy))))
+ (_ (if (null? (syntax dy))
+ (syntax (list x))
+ (syntax (cons x y))))))
+ ((listp . stuff)
+ (islist? (syntax listp))
+ (syntax (list x . stuff)))
+ (else (syntax (cons x y)))))))
+ (quasiappend
+ (lambda (x y)
+ (let ((ls (let f ((x x))
+ (if (null? x)
+ (if (quote-nil? y)
+ '()
+ (list y))
+ (if (quote-nil? (car x))
+ (f (cdr x))
+ (cons (car x) (f (cdr x))))))))
+ (cond
+ ((null? ls) (syntax (quote ())))
+ ((null? (cdr ls)) (car ls))
+ (else (with-syntax (((p ...) ls))
+ (syntax (append p ...))))))))
+ (quasivector
+ (lambda (x)
+ (with-syntax ((pat-x x))
+ (syntax-case (syntax pat-x) ()
+ ((quote? (x ...))
+ (isquote? (syntax quote?))
+ (syntax (quote #(x ...))))
+ (_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls))))
+ (syntax-case x ()
+ ((quote? (x ...))
+ (isquote? (syntax quote?))
+ (k (syntax ((quote x) ...))))
+ ((listp x ...)
+ (islist? (syntax listp))
+ (k (syntax (x ...))))
+ ((cons? x y)
+ (iscons? (syntax cons?))
+ (f (syntax y) (lambda (ls) (k (cons (syntax x) ls)))))
+ (else
+ (syntax (list->vector pat-x))))))))))
+ (quasi
+ (lambda (p lev)
+ (syntax-case p (unquote unquote-splicing quasiquote)
+ ((unquote p)
+ (if (= lev 0)
+ (syntax p)
+ (quasicons (syntax (quote unquote))
+ (quasi (syntax (p)) (- lev 1)))))
+ (((unquote p ...) . q)
+ (if (= lev 0)
+ (quasilist* (syntax (p ...)) (quasi (syntax q) lev))
+ (quasicons (quasicons (syntax (quote unquote))
+ (quasi (syntax (p ...)) (- lev 1)))
+ (quasi (syntax q) lev))))
+ (((unquote-splicing p ...) . q)
+ (if (= lev 0)
+ (quasiappend (syntax (p ...)) (quasi (syntax q) lev))
+ (quasicons (quasicons (syntax (quote unquote-splicing))
+ (quasi (syntax (p ...)) (- lev 1)))
+ (quasi (syntax q) lev))))
+ ((quasiquote p)
+ (quasicons (syntax (quote quasiquote))
+ (quasi (syntax (p)) (+ lev 1))))
+ ((p . q)
+ (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
+ (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
+ (p (syntax (quote p)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e) (quasi (syntax e) 0))))))
+
+(define-syntax include
+ (lambda (x)
+ (define read-file
+ (lambda (fn k)
+ (let ((p (open-input-file fn)))
+ (let f ()
+ (let ((x (read p)))
+ (if (eof-object? x)
+ (begin (close-input-port p) '())
+ (cons (datum->syntax-object k x) (f))))))))
+ (syntax-case x ()
+ ((k filename)
+ (let ((fn (syntax-object->datum (syntax filename))))
+ (with-syntax (((exp ...) (read-file fn (syntax k))))
+ (syntax (begin exp ...))))))))
+
+(define-syntax unquote
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e ...)
+ (syntax-error x
+ "expression not valid outside of quasiquote")))))
+
+(define-syntax unquote-splicing
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e ...)
+ (syntax-error x
+ "expression not valid outside of quasiquote")))))
+
+(define-syntax case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e m1 m2 ...)
+ (with-syntax
+ ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
+ (if (null? clauses)
+ (syntax-case clause (else)
+ ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
+ (((k ...) e1 e2 ...)
+ (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
+ (_ (syntax-error x)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else)
+ (((k ...) e1 e2 ...)
+ (syntax (if (memv t '(k ...))
+ (begin e1 e2 ...)
+ rest)))
+ (_ (syntax-error x))))))))
+ (syntax (let ((t e)) body)))))))
+
+(define-syntax identifier-syntax
+ (lambda (x)
+ (syntax-case x (set!)
+ ((_ e)
+ (syntax
+ (lambda (x)
+ (syntax-case x ()
+ (id
+ (identifier? (syntax id))
+ (syntax e))
+ ((_ x (... ...))
+ (syntax (e x (... ...))))))))
+ ((_ (id exp1) ((set! var val) exp2))
+ (and (identifier? (syntax id)) (identifier? (syntax var)))
+ (syntax
+ (cons 'macro!
+ (lambda (x)
+ (syntax-case x (set!)
+ ((set! var val) (syntax exp2))
+ ((id x (... ...)) (syntax (exp1 x (... ...))))
+ (id (identifier? (syntax id)) (syntax exp1))))))))))
+
--- /dev/null
+;;; Guile R5RS
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language r5rs spec)
+ #:use-module (system base language)
+ #:use-module (language r5rs expand)
+ #:use-module (language r5rs translate)
+ #:export (r5rs))
+
+\f
+;;;
+;;; Translator
+;;;
+
+(define (translate x) (if (pair? x) (translate-pair x) x))
+
+(define (translate-pair x)
+ (let ((head (car x)) (rest (cdr x)))
+ (case head
+ ((quote) (cons '@quote rest))
+ ((define set! if and or begin)
+ (cons (symbol-append '@ head) (map translate rest)))
+ ((let let* letrec)
+ (cons* (symbol-append '@ head)
+ (map (lambda (b) (cons (car b) (map translate (cdr b))))
+ (car rest))
+ (map translate (cdr rest))))
+ ((lambda)
+ (cons* '@lambda (car rest) (map translate (cdr rest))))
+ (else
+ (cons (translate head) (map translate rest))))))
+
+\f
+;;;
+;;; Language definition
+;;;
+
+(define-language r5rs
+ #:title "Standard Scheme (R5RS + syntax-case)"
+ #:version "0.3"
+ #:reader read
+ #:expander expand
+ #:translator translate
+ #:printer write
+;; #:environment (global-ref 'Language::R5RS::core)
+ )
--- /dev/null
+(define-module (language scheme amatch)
+ #:use-module (ice-9 syncase)
+ #:export (amatch apat))
+;; FIXME: shouldn't have to export apat...
+
+;; This is exactly the same as pmatch except that it unpacks annotations
+;; as needed.
+
+(define-syntax amatch
+ (syntax-rules (else guard)
+ ((_ (op arg ...) cs ...)
+ (let ((v (op arg ...)))
+ (amatch v cs ...)))
+ ((_ v) (if #f #f))
+ ((_ v (else e0 e ...)) (begin e0 e ...))
+ ((_ v (pat (guard g ...) e0 e ...) cs ...)
+ (let ((fk (lambda () (amatch v cs ...))))
+ (apat v pat
+ (if (and g ...) (begin e0 e ...) (fk))
+ (fk))))
+ ((_ v (pat e0 e ...) cs ...)
+ (let ((fk (lambda () (amatch v cs ...))))
+ (apat v pat (begin e0 e ...) (fk))))))
+
+(define-syntax apat
+ (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 (apair? v)
+ (let ((vx (acar v)) (vy (acdr v)))
+ (apat vx x (apat vy y kt kf) kf))
+ kf))
+ ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
--- /dev/null
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme compile-ghil)
+ #:use-module (system base pmatch)
+ #:use-module (system base language)
+ #:use-module (language ghil)
+ #:use-module (language scheme inline)
+ #:use-module (system vm objcode)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 optargs)
+ #:use-module ((ice-9 syncase) #:select (sc-macro))
+ #:use-module ((system base compile) #:select (syntax-error))
+ #:export (compile-ghil translate-1
+ *translate-table* define-scheme-translator))
+
+
+;;; environment := #f
+;;; | MODULE
+;;; | COMPILE-ENV
+;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+(define (cenv-module env)
+ (cond ((not env) #f)
+ ((module? env) env)
+ ((and (pair? env) (module? (car env))) (car env))
+ (else (error "bad environment" env))))
+
+(define (cenv-ghil-env env)
+ (cond ((not env) (make-ghil-toplevel-env))
+ ((module? env) (make-ghil-toplevel-env))
+ ((pair? env)
+ (ghil-env-dereify (cadr env)))
+ (else (error "bad environment" env))))
+
+(define (cenv-externals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (cddr env))
+ (else (error "bad environment" env))))
+
+
+\f
+
+(define (compile-ghil x e opts)
+ (save-module-excursion
+ (lambda ()
+ (and=> (cenv-module e) set-current-module)
+ (call-with-ghil-environment (cenv-ghil-env e) '()
+ (lambda (env vars)
+ (values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))
+ (and e
+ (cons* (cenv-module e)
+ (ghil-env-parent env)
+ (cenv-externals e)))))))))
+
+\f
+;;;
+;;; Translator
+;;;
+
+(define *forbidden-primitives*
+ ;; Guile's `procedure->macro' family is evil because it crosses the
+ ;; compilation boundary. One solution might be to evaluate calls to
+ ;; `procedure->memoizing-macro' at compilation time, but it may be more
+ ;; compicated than that.
+ '(procedure->syntax procedure->macro))
+
+;; Looks up transformers relative to the current module at
+;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
+;;
+;; FIXME shadowing lexicals?
+(define (lookup-transformer head retrans)
+ (let* ((mod (current-module))
+ (val (cond
+ ((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)))))
+ ;; allow macros to be unquoted into the output of a macro
+ ;; expansion
+ ((macro? head) head)
+ (else #f))))
+ (cond
+ ((hashq-ref *translate-table* val))
+
+ ((defmacro? val)
+ (lambda (env loc exp)
+ (retrans (apply (defmacro-transformer val) (cdr exp)))))
+
+ ((eq? val sc-macro)
+ ;; syncase!
+ (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
+ (sc-expand3 (@@ (ice-9 syncase) 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 (translate-1 e l x)
+ (let ((l (or l (location x))))
+ (define (retrans x) (translate-1 e #f x))
+ (define (retrans/loc x) (translate-1 e (or (location x) l) x))
+ (cond ((pair? x)
+ (let ((head (car x)) (tail (cdr x)))
+ (cond
+ ((lookup-transformer head retrans/loc)
+ => (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 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 *translate-table* (make-hash-table))
+
+(define-macro (-> form)
+ `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
+
+(define-macro (define-scheme-translator sym . clauses)
+ `(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
+ ,sym
+ (lambda (e l exp)
+ (define (retrans x)
+ ((@ (language scheme compile-ghil) translate-1)
+ e
+ (or ((@@ (language scheme compile-ghil) location) x) l)
+ x))
+ (define syntax-error (@ (system base compile) syntax-error))
+ (pmatch (cdr exp)
+ ,@clauses
+ ,@(if (assq 'else clauses) '()
+ `((else
+ (syntax-error l (format #f "bad ~A" ',sym) exp))))))))
+
+(define-scheme-translator quote
+ ;; (quote OBJ)
+ ((,obj)
+ (-> (quote obj))))
+
+(define-scheme-translator quasiquote
+ ;; (quasiquote OBJ)
+ ((,obj)
+ (-> (quasiquote (trans-quasiquote e l obj 0)))))
+
+(define-scheme-translator define
+ ;; (define NAME VAL)
+ ((,name ,val) (guard (symbol? name)
+ (ghil-toplevel-env? (ghil-env-parent e)))
+ (-> (define (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)))))
+
+(define-scheme-translator set!
+ ;; (set! NAME VAL)
+ ((,name ,val) (guard (symbol? name))
+ (-> (set (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 '@)))
+ (-> (set (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 '@@)))
+ (-> (set (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)))))
+
+(define-scheme-translator if
+ ;; (if TEST THEN [ELSE])
+ ((,test ,then)
+ (-> (if (retrans test) (retrans then) (retrans '(begin)))))
+ ((,test ,then ,else)
+ (-> (if (retrans test) (retrans then) (retrans else)))))
+
+(define-scheme-translator and
+ ;; (and EXPS...)
+ (,tail
+ (-> (and (map retrans tail)))))
+
+(define-scheme-translator or
+ ;; (or EXPS...)
+ (,tail
+ (-> (or (map retrans tail)))))
+
+(define-scheme-translator begin
+ ;; (begin EXPS...)
+ (,tail
+ (-> (begin (map retrans tail)))))
+
+(define-scheme-translator 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'
+ (-> (begin (list (trans-body e l body)))))
+
+ ;; (let ((SYM VAL) ...) BODY...)
+ ((,bindings . ,body) (guard (valid-bindings? bindings))
+ (let ((vals (map (lambda (b)
+ (maybe-name-value! (retrans (cadr b)) (car b)))
+ bindings)))
+ (call-with-ghil-bindings e (map car bindings)
+ (lambda (vars)
+ (-> (bind vars vals (trans-body e l body))))))))
+
+(define-scheme-translator let*
+ ;; (let* ((SYM VAL) ...) BODY...)
+ ((() . ,body)
+ (retrans `(let () ,@body)))
+ ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
+ (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
+
+(define-scheme-translator letrec
+ ;; (letrec ((SYM VAL) ...) BODY...)
+ ((,bindings . ,body) (guard (valid-bindings? bindings))
+ (call-with-ghil-bindings e (map car bindings)
+ (lambda (vars)
+ (let ((vals (map (lambda (b)
+ (maybe-name-value!
+ (retrans (cadr b)) (car b)))
+ bindings)))
+ (-> (bind vars vals (trans-body e l body))))))))
+
+(define-scheme-translator 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)))))
+
+(define-scheme-translator 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))))))))))
+
+(define-scheme-translator 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))))))
+
+(define-scheme-translator lambda
+ ;; (lambda FORMALS BODY...)
+ ((,formals . ,body)
+ (receive (syms rest) (parse-formals formals)
+ (call-with-ghil-environment e syms
+ (lambda (e vars)
+ (receive (meta body) (parse-lambda-meta body)
+ (-> (lambda vars rest meta (trans-body e l body)))))))))
+
+(define-scheme-translator delay
+ ;; FIXME not hygienic
+ ((,expr)
+ (retrans `(make-promise (lambda () ,expr)))))
+
+(define-scheme-translator @
+ ((,modname ,sym)
+ (-> (ref (ghil-var-at-module! e modname sym #t)))))
+
+(define-scheme-translator @@
+ ((,modname ,sym)
+ (-> (ref (ghil-var-at-module! e modname sym #f)))))
+
+(define *the-compile-toplevel-symbol* 'compile-toplevel)
+(define-scheme-translator eval-when
+ ((,when . ,body) (guard (list? when) (and-map symbol? when))
+ (if (memq 'compile when)
+ (primitive-eval `(begin . ,body)))
+ (if (memq 'load when)
+ (retrans `(begin . ,body))
+ (retrans `(begin)))))
+
+(define-scheme-translator apply
+ ;; FIXME: not hygienic, relies on @apply not being shadowed
+ (,args (retrans `(@apply ,@args))))
+
+;; FIXME: we could add inliners for `list' and `vector'
+
+(define-scheme-translator @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
+ (-> (inline 'apply (cons (retrans proc) args))))))))
+
+(define-scheme-translator call-with-values
+ ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
+ ((,producer ,consumer)
+ (retrans `(@call-with-values ,producer ,consumer)))
+ (else #f))
+
+(define-scheme-translator @call-with-values
+ ((,producer ,consumer)
+ (-> (mv-call (retrans producer) (retrans consumer)))))
+
+(define-scheme-translator call-with-current-continuation
+ ;; FIXME: not hygienic, relies on @call-with-current-continuation
+ ;; not being shadowed
+ ((,proc)
+ (retrans `(@call-with-current-continuation ,proc)))
+ (else #f))
+
+(define-scheme-translator @call-with-current-continuation
+ ((,proc)
+ (-> (inline 'call/cc (list (retrans proc))))))
+
+(define-scheme-translator 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)
+ (let ((producer (retrans `(lambda () ,producer-exp))))
+ (call-with-ghil-bindings e syms
+ (lambda (vars)
+ (-> (mv-bind producer vars rest
+ (trans-body e l body)))))))))
+
+(define-scheme-translator values
+ ((,x) (retrans x))
+ (,args
+ (-> (values (map retrans args)))))
+
+(define-scheme-translator compile-time-environment
+ ;; (compile-time-environment)
+ ;; => (MODULE LEXICALS . EXTERNALS)
+ (()
+ (-> (inline 'cons
+ (list (retrans '(current-module))
+ (-> (inline 'cons
+ (list (-> (reified-env))
+ (-> (inline 'externals '()))))))))))
+
+(define (lookup-apply-transformer proc)
+ (cond ((eq? proc values)
+ (lambda (e l args)
+ (-> (values* 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)
+ (-> (unquote (translate-1 e l obj)))
+ (-> (unquote-splicing (translate-1 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)
+ (translate-1 e l `(begin ,@ls))
+ (translate-1 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))
+ props))))
--- /dev/null
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme expand)
+ #:use-module (language scheme amatch)
+ #:use-module (ice-9 annotate)
+ #:use-module (ice-9 optargs)
+ #:use-module ((ice-9 syncase) #:select (sc-macro))
+ #:use-module ((system base compile) #:select (syntax-error))
+ #:export (expand *expand-table* define-scheme-expander))
+
+(define (aref x) (if (annotation? x) (annotation-expression x) x))
+(define (apair? x) (pair? (aref x)))
+(define (acar x) (car (aref x)))
+(define (acdr x) (cdr (aref x)))
+(define (acaar x) (acar (acar x)))
+(define (acdar x) (acdr (acar x)))
+(define (acadr x) (acar (acdr x)))
+(define (acddr x) (acdr (acdr x)))
+(define (aloc x) (and (annotation? x) (annotation-source x)))
+(define (re-annotate x y)
+ (if (annotation? x)
+ (make-annotation y (annotation-source x))
+ y))
+(define-macro (-> exp) `(re-annotate x ,exp))
+
+(define* (expand x #:optional (mod (current-module)) (once? #f))
+ (define re-expand
+ (if once?
+ (lambda (x) x)
+ (lambda (x) (expand x mod once?))))
+ (let ((exp (if (annotation? x) (annotation-expression x) x)))
+ (cond
+ ((pair? exp)
+ (let ((head (car exp)) (tail (cdr exp)))
+ (cond
+ ;; allow macros to be unquoted into the output of a macro
+ ;; expansion
+ ((or (symbol? head) (macro? head))
+ (let ((val (cond
+ ((macro? head) head)
+ ((module-variable mod head)
+ => (lambda (var)
+ ;; unbound vars can happen if the module
+ ;; definition forward-declared them
+ (and (variable-bound? var) (variable-ref var))))
+ (else #f))))
+ (cond
+ ((hashq-ref *expand-table* val)
+ => (lambda (expand1) (expand1 x re-expand)))
+
+ ((defmacro? val)
+ (re-expand (-> (apply (defmacro-transformer val)
+ (deannotate tail)))))
+
+ ((eq? val sc-macro)
+ ;; syncase!
+ (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
+ (sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
+ (re-expand
+ (with-fluids ((eec (module-eval-closure mod)))
+ ;; fixme
+ (sc-expand3 (deannotate exp) 'c '(compile load eval))))))
+
+ ((primitive-macro? val)
+ (syntax-error (aloc x) "unhandled primitive macro" head))
+
+ ((macro? val)
+ (syntax-error (aloc x) "unknown kind of macro" head))
+
+ (else
+ (-> (cons head (map re-expand tail)))))))
+
+ (else
+ (-> (map re-expand exp))))))
+
+ (else x))))
+
+
+(define *expand-table* (make-hash-table))
+
+(define-macro (define-scheme-expander sym . clauses)
+ `(hashq-set! (@ (language scheme expand) *expand-table*)
+ ,sym
+ (lambda (x re-expand)
+ (define syntax-error (@ (system base compile) syntax-error))
+ (amatch (acdr x)
+ ,@clauses
+ ,@(if (assq 'else clauses) '()
+ `((else
+ (syntax-error (aloc x) (format #f "bad ~A" ',sym) x))))))))
+
+(define-scheme-expander quote
+ ;; (quote OBJ)
+ ((,obj) x))
+
+(define-scheme-expander quasiquote
+ ;; (quasiquote OBJ)
+ ((,obj)
+ (-> `(,'quasiquote
+ ,(let lp ((x obj) (level 0))
+ (cond ((not (apair? x)) x)
+ ;; FIXME: hygiene regarding imported , / ,@ rebinding
+ ((memq (acar x) '(unquote unquote-splicing))
+ (amatch (acdr x)
+ ((,obj)
+ (cond
+ ((zero? level)
+ (-> `(,(acar x) ,(re-expand obj))))
+ (else
+ (-> `(,(acar x) ,(lp obj (1- level)))))))
+ (else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x))))
+ ((eq? (acar x) 'quasiquote)
+ (amatch (acdr x)
+ ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level)))))
+ (else (syntax-error (aloc x) "bad quasiquote" x))))
+ (else (-> (cons (lp (acar x) level) (lp (acdr x) level))))))))))
+
+(define-scheme-expander define
+ ;; (define NAME VAL)
+ ((,name ,val) (guard (symbol? name))
+ (-> `(define ,name ,(re-expand val))))
+ ;; (define (NAME FORMALS...) BODY...)
+ (((,name . ,formals) . ,body) (guard (symbol? name))
+ ;; -> (define NAME (lambda FORMALS BODY...))
+ (re-expand (-> `(define ,name (lambda ,formals . ,body))))))
+
+(define-scheme-expander set!
+ ;; (set! (NAME ARGS...) VAL)
+ (((,name . ,args) ,val) (guard (symbol? name)
+ (not (eq? name '@)) (not (eq? name '@@)))
+ ;; -> ((setter NAME) ARGS... VAL)
+ (re-expand (-> `((setter ,name) ,@args ,val))))
+
+ ;; (set! NAME VAL)
+ ((,name ,val) (guard (symbol? name))
+ (-> `(set! ,name ,(re-expand val)))))
+
+(define-scheme-expander if
+ ;; (if TEST THEN [ELSE])
+ ((,test ,then)
+ (-> `(if ,(re-expand test) ,(re-expand then))))
+ ((,test ,then ,else)
+ (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else)))))
+
+(define-scheme-expander and
+ ;; (and EXPS...)
+ (,tail
+ (-> `(and . ,(map re-expand tail)))))
+
+(define-scheme-expander or
+ ;; (or EXPS...)
+ (,tail
+ (-> `(or . ,(map re-expand tail)))))
+
+(define-scheme-expander begin
+ ;; (begin EXPS...)
+ ((,single-exp)
+ (-> (re-expand single-exp)))
+ (,tail
+ (-> `(begin . ,(map re-expand tail)))))
+
+(define (valid-bindings? bindings . it-is-for-do)
+ (define (valid-binding? b)
+ (amatch b
+ ((,sym ,var) (guard (symbol? sym)) #t)
+ ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
+ (else #f)))
+ (and (list? (aref bindings))
+ (and-map valid-binding? (aref bindings))))
+
+(define-scheme-expander let
+ ;; (let NAME ((SYM VAL) ...) BODY...)
+ ((,name ,bindings . ,body) (guard (symbol? name)
+ (valid-bindings? bindings))
+ ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
+ (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings))
+ . ,body)))
+ (,name . ,(map acadr (aref bindings)))))))
+
+ ((() . ,body)
+ (re-expand (expand-internal-defines body)))
+
+ ;; (let ((SYM VAL) ...) BODY...)
+ ((,bindings . ,body) (guard (valid-bindings? bindings))
+ (-> `(let ,(map (lambda (x)
+ ;; nb, relies on -> non-hygiene
+ (-> `(,(acar x) ,(re-expand (acadr x)))))
+ (aref bindings))
+ ,(expand-internal-defines (map re-expand body))))))
+
+(define-scheme-expander let*
+ ;; (let* ((SYM VAL) ...) BODY...)
+ ((() . ,body)
+ (re-expand (-> `(let () . ,body))))
+ ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
+ (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body))))))
+
+(define-scheme-expander letrec
+ ;; (letrec ((SYM VAL) ...) BODY...)
+ ((,bindings . ,body) (guard (valid-bindings? bindings))
+ (-> `(letrec ,(map (lambda (x)
+ ;; nb, relies on -> non-hygiene
+ (-> `(,(acar x) ,(re-expand (acadr x)))))
+ (aref bindings))
+ ,(expand-internal-defines (map re-expand body))))))
+
+(define-scheme-expander cond
+ ;; (cond (CLAUSE BODY...) ...)
+ (() (-> '(begin)))
+ (((else . ,body)) (re-expand (-> `(begin ,@body))))
+ (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest)))))
+ (((,test => ,proc) . ,rest)
+ ;; FIXME hygiene!
+ (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))))
+ (((,test . ,body) . ,rest)
+ (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest))))))
+
+(define-scheme-expander case
+ ;; (case EXP ((KEY...) BODY...) ...)
+ ((,exp . ,clauses)
+ ;; FIXME hygiene!
+ (re-expand
+ (->`(let ((_t ,exp))
+ ,(let loop ((ls clauses))
+ (cond ((null? ls) '(begin))
+ ((eq? (acaar ls) 'else) `(begin ,@(acdar ls)))
+ (else `(if (memv _t ',(acaar ls))
+ (begin ,@(acdar ls))
+ ,(loop (acdr ls)))))))))))
+
+(define-scheme-expander do
+ ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
+ ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t))
+ (let ((sym (map acar (aref bindings)))
+ (val (map acadr (aref bindings)))
+ (update (map acddr (aref bindings))))
+ (define (next s x) (if (pair? x) (car x) s))
+ (re-expand
+ ;; FIXME hygiene!
+ (-> `(letrec ((_l (lambda ,sym
+ (if ,test
+ (begin ,@result)
+ (begin ,@body
+ (_l ,@(map next sym update)))))))
+ (_l ,@val)))))))
+
+(define-scheme-expander lambda
+ ;; (lambda FORMALS BODY...)
+ ((,formals ,docstring ,body1 . ,body) (guard (string? docstring))
+ (-> `(lambda ,formals ,docstring ,(expand-internal-defines
+ (map re-expand (cons body1 body))))))
+ ((,formals . ,body)
+ (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body))))))
+
+(define-scheme-expander delay
+ ;; FIXME not hygienic
+ ((,expr)
+ (re-expand `(make-promise (lambda () ,expr)))))
+
+(define-scheme-expander @
+ ((,modname ,sym)
+ x))
+
+(define-scheme-expander @@
+ ((,modname ,sym)
+ x))
+
+(define-scheme-expander eval-when
+ ((,when . ,body) (guard (list? when) (and-map symbol? when))
+ (if (memq 'compile when)
+ (primitive-eval `(begin . ,body)))
+ (if (memq 'load when)
+ (-> `(begin . ,body))
+ (-> `(begin)))))
+
+;;; Hum, I don't think this takes imported modifications to `define'
+;;; properly into account. (Lexical bindings are OK because of alpha
+;;; renaming.)
+(define (expand-internal-defines body)
+ (let loop ((ls body) (ds '()))
+ (amatch ls
+ (() (syntax-error l "bad body" body))
+ (((define ,name ,val) . _)
+ (loop (acdr ls) (cons (list name val) ds)))
+ (else
+ (if (null? ds)
+ (if (null? (cdr ls)) (car ls) `(begin ,@ls))
+ `(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls))))))))
--- /dev/null
+;;; GHIL macros
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme inline)
+ #:use-module (system base syntax)
+ #:use-module (language 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! (@ (language scheme inline) *inline-table*)
+ (assq-set! (@ (language scheme inline) *inline-table*)
+ ,sym
+ (let ((make-ghil-inline (@ (language ghil) make-ghil-inline))
+ (make-ghil-quote (@ (language ghil) make-ghil-quote))
+ (try-inline (@ (language scheme inline) try-inline)))
+ (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)))
+
+(define-inline acons
+ (x y z) (cons (cons x y) z))
--- /dev/null
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme spec)
+ #:use-module (system base language)
+ #:use-module (language scheme compile-ghil)
+ #: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
+ #:compilers `((ghil . ,compile-ghil))
+ #:evaluator (lambda (x module) (primitive-eval x))
+ #:printer write
+ )
--- /dev/null
+;;; Guile Lowlevel 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 value spec)
+ #:use-module (system base language)
+ #:export (value))
+
+(define-language value
+ #:title "Guile Values"
+ #:version "0.3"
+ #:reader #f
+ #:printer write
+ )
SUBDIRS = goops
-# These should be installed and distributed.
-oop_sources = goops.scm
+modpath = oop
+SOURCES = goops.scm
+include $(top_srcdir)/am/guilec
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/oop
-subpkgdata_DATA = $(oop_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(oop_sources) ChangeLog-2008
+EXTRA_DIST += ChangeLog-2008
;;;;
(define-module (oop goops)
+ :use-module (srfi srfi-1)
:export-syntax (define-class class standard-define-class
define-generic define-accessor define-method
define-extended-generic define-extended-generics
make-generic ensure-generic
make-extended-generic
make-accessor ensure-accessor
- process-class-pre-define-generic
- process-class-pre-define-accessor
- process-define-generic
- process-define-accessor
- make-method add-method!
- object-eqv? object-equal?
+ add-method!
class-slot-ref class-slot-set! slot-unbound slot-missing
slot-definition-name slot-definition-options
slot-definition-allocation
:replace (<class> <operator-class> <entity-class> <entity>)
:no-backtrace)
+(define *goops-module* (current-module))
+
;; First initialize the builtin part of GOOPS
-(%init-goops-builtins)
+(eval-when (eval load compile)
+ (%init-goops-builtins))
;; Then load the rest of GOOPS
(use-modules (oop goops util)
(oop goops compile))
\f
-(define min-fixnum (- (expt 2 29)))
-
-(define max-fixnum (- (expt 2 29) 1))
+(eval-when (eval load compile)
+ (define min-fixnum (- (expt 2 29)))
+ (define max-fixnum (- (expt 2 29) 1)))
;;
;; goops-error
(if (null? supers)
<class>
(let* ((all-metas (map (lambda (x) (class-of x)) supers))
- (all-cpls (apply append
- (map (lambda (m)
- (cdr (class-precedence-list m)))
- all-metas)))
+ (all-cpls (append-map (lambda (m)
+ (cdr (class-precedence-list m)))
+ all-metas))
(needed-metas '()))
;; Find the most specific metaclasses. The new metaclass will be
;; a subclass of these.
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
-(define (define-class-pre-definition keyword exp env)
- (case keyword
+(define (define-class-pre-definition kw val)
+ (case kw
((#:getter #:setter)
- `(process-class-pre-define-generic ',exp))
+ `(if (or (not (defined? ',val))
+ (not (is-a? ,val <generic>)))
+ (define-generic ,val)))
((#:accessor)
- `(process-class-pre-define-accessor ',exp))
+ `(if (or (not (defined? ',val))
+ (not (is-a? ,val <accessor>)))
+ (define-accessor ,val)))
(else #f)))
-(define (process-class-pre-define-generic name)
- (let ((var (module-variable (current-module) name)))
- (if (not (and var
- (variable-bound? var)
- (is-a? (variable-ref var) <generic>)))
- (process-define-generic name))))
-
-(define (process-class-pre-define-accessor name)
- (let ((var (module-variable (current-module) name)))
- (cond ((or (not var)
- (not (variable-bound? var)))
- (process-define-accessor name))
- ((or (is-a? (variable-ref var) <accessor>)
- (is-a? (variable-ref var) <extended-generic-with-setter>)))
- ((is-a? (variable-ref var) <generic>)
- ;;*fixme* don't mutate an imported object!
- (variable-set! var (ensure-accessor (variable-ref var) name)))
- (else
- (process-define-accessor name)))))
+(define (kw-do-map mapper f kwargs)
+ (define (keywords l)
+ (cond
+ ((null? l) '())
+ ((or (null? (cdr l)) (not (keyword? (car l))))
+ (goops-error "malformed keyword arguments: ~a" kwargs))
+ (else (cons (car l) (keywords (cddr l))))))
+ (define (args l)
+ (if (null? l) '() (cons (cadr l) (args (cddr l)))))
+ ;; let* to check keywords first
+ (let* ((k (keywords kwargs))
+ (a (args kwargs)))
+ (mapper f k a)))
;;; This code should be implemented in C.
;;;
-(define define-class
- (letrec (;; Some slot options require extra definitions to be made.
- ;; In particular, we want to make sure that the generic
- ;; function objects which represent accessors exist
- ;; before `make-class' tries to add methods to them.
- ;;
- ;; Postpone error handling to class macro.
- ;;
- (pre-definitions
- (lambda (slots env)
- (do ((slots slots (cdr slots))
- (definitions '()
- (if (pair? (car slots))
- (do ((options (cdar slots) (cddr options))
- (definitions definitions
- (cond ((not (symbol? (cadr options)))
- definitions)
- ((define-class-pre-definition
- (car options)
- (cadr options)
- env)
- => (lambda (definition)
- (cons definition definitions)))
- (else definitions))))
- ((not (and (pair? options)
- (pair? (cdr options))))
- definitions))
- definitions)))
- ((or (not (pair? slots))
- (keyword? (car slots)))
- (reverse definitions)))))
-
- ;; Syntax
- (name cadr)
- (slots cdddr))
-
- (procedure->memoizing-macro
- (lambda (exp env)
- (cond ((not (top-level-env? env))
- (goops-error "define-class: Only allowed at top level"))
- ((not (and (list? exp) (>= (length exp) 3)))
- (goops-error "missing or extra expression"))
- (else
- (let ((name (name exp)))
- `(begin
- ;; define accessors
- ,@(pre-definitions (slots exp) env)
- ;; update the current-module
- (let* ((class (class ,@(cddr exp) #:name ',name))
- (var (module-ensure-local-variable!
- (current-module) ',name))
- (old (and (variable-bound? var)
- (variable-ref var))))
- (if (and old
- (is-a? old <class>)
- (memq <object> (class-precedence-list old)))
- (variable-set! var (class-redefinition old class))
- (variable-set! var class)))))))))))
+(define-macro (define-class name supers . slots)
+ ;; Some slot options require extra definitions to be made. In
+ ;; particular, we want to make sure that the generic function objects
+ ;; which represent accessors exist before `make-class' tries to add
+ ;; methods to them.
+ ;;
+ ;; Postpone some error handling to class macro.
+ ;;
+ `(begin
+ ;; define accessors
+ ,@(append-map (lambda (slot)
+ (kw-do-map filter-map
+ define-class-pre-definition
+ (if (pair? slot) (cdr slot) '())))
+ (take-while (lambda (x) (not (keyword? x))) slots))
+ (if (and (defined? ',name)
+ (is-a? ,name <class>)
+ (memq <object> (class-precedence-list ,name)))
+ (class-redefinition ,name
+ (class ,supers ,@slots #:name ',name))
+ (define ,name (class ,supers ,@slots #:name ',name)))))
(define standard-define-class define-class)
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
-(define class
- (letrec ((slot-option-keyword car)
- (slot-option-value cadr)
- (process-slot-options
- (lambda (options)
- (let loop ((options options)
- (res '()))
- (cond ((null? options)
- (reverse res))
- ((null? (cdr options))
- (goops-error "malformed slot option list"))
- ((not (keyword? (slot-option-keyword options)))
- (goops-error "malformed slot option list"))
- (else
- (case (slot-option-keyword options)
- ((#:init-form)
- (loop (cddr options)
- (append (list `(lambda ()
- ,(slot-option-value options))
- #:init-thunk
- (list 'quote
- (slot-option-value options))
- #:init-form)
- res)))
- (else
- (loop (cddr options)
- (cons (cadr options)
- (cons (car options)
- res)))))))))))
+(define-macro (class supers . slots)
+ (define (make-slot-definition-forms slots)
+ (map
+ (lambda (def)
+ (cond
+ ((pair? def)
+ `(list ',(car def)
+ ,@(kw-do-map append-map
+ (lambda (kw arg)
+ (case kw
+ ((#:init-form)
+ `(#:init-form ',arg
+ #:init-thunk (lambda () ,arg)))
+ (else (list kw arg))))
+ (cdr def))))
+ (else
+ `(list ',def))))
+ slots))
- (procedure->memoizing-macro
- (let ((supers cadr)
- (slots cddr)
- (options cdddr))
- (lambda (exp env)
- (cond ((not (and (list? exp) (>= (length exp) 2)))
- (goops-error "missing or extra expression"))
- ((not (list? (supers exp)))
- (goops-error "malformed superclass list: ~S" (supers exp)))
- (else
- (let ((slot-defs (cons #f '())))
- (do ((slots (slots exp) (cdr slots))
- (defs slot-defs (cdr defs)))
- ((or (null? slots)
- (keyword? (car slots)))
- `(make-class
- ;; evaluate super class variables
- (list ,@(supers exp))
- ;; evaluate slot definitions, except the slot name!
- (list ,@(cdr slot-defs))
- ;; evaluate class options
- ,@slots
- ;; place option last in case someone wants to
- ;; pass a different value
- #:environment ',env))
- (set-cdr!
- defs
- (list (if (pair? (car slots))
- `(list ',(slot-definition-name (car slots))
- ,@(process-slot-options
- (slot-definition-options
- (car slots))))
- `(list ',(car slots))))))))))))))
+ (if (not (list? supers))
+ (goops-error "malformed superclass list: ~S" supers))
+ (let ((slot-defs (cons #f '()))
+ (slots (take-while (lambda (x) (not (keyword? x))) slots))
+ (options (or (find-tail keyword? slots) '())))
+ `(make-class
+ ;; evaluate super class variables
+ (list ,@supers)
+ ;; evaluate slot definitions, except the slot name!
+ (list ,@(make-slot-definition-forms slots))
+ ;; evaluate class options
+ ,@options)))
(define (make-class supers slots . options)
(let ((env (or (get-keyword #:environment options #f)
;;; {Generic functions and accessors}
;;;
-(define define-generic
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp)))
- (cond ((not (symbol? name))
- (goops-error "bad generic function name: ~S" name))
- ((top-level-env? env)
- `(process-define-generic ',name))
- (else
- `(define ,name (make <generic> #:name ',name))))))))
-
-(define (process-define-generic name)
- (let ((var (module-ensure-local-variable! (current-module) name)))
- (if (or (not var)
- (not (variable-bound? var))
- (is-a? (variable-ref var) <generic>))
- ;; redefine if NAME isn't defined previously, or is another generic
- (variable-set! var (make <generic> #:name name))
- ;; otherwise try to upgrade the object to a generic
- (variable-set! var (ensure-generic (variable-ref var) name)))))
-
-(define define-extended-generic
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp)))
- (cond ((not (symbol? name))
- (goops-error "bad generic function name: ~S" name))
- ((null? (cddr exp))
- (goops-error "missing expression"))
- (else
- `(define ,name (make-extended-generic ,(caddr exp) ',name))))))))
-(define define-extended-generics
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((names (cadr exp))
- (prefixes (get-keyword #:prefix (cddr exp) #f)))
- (if prefixes
- `(begin
- ,@(map (lambda (name)
- `(define-extended-generic ,name
- (list ,@(map (lambda (prefix)
- (symbol-append prefix name))
- prefixes))))
- names))
- (goops-error "no prefixes supplied"))))))
+;; Apparently the desired semantics are that we extend previous
+;; procedural definitions, but that if `name' was already a generic, we
+;; overwrite its definition.
+(define-macro (define-generic name)
+ (if (not (symbol? name))
+ (goops-error "bad generic function name: ~S" name))
+ `(define ,name
+ (if (and (defined? ',name) (is-a? ,name <generic>))
+ (make <generic> #:name ',name)
+ (ensure-generic (if (defined? ',name) ,name #f) ',name))))
+
+(define-macro (define-extended-generic name val)
+ (if (not (symbol? name))
+ (goops-error "bad generic function name: ~S" name))
+ `(define ,name (make-extended-generic ,val ',name)))
+
+(define-macro (define-extended-generics names . args)
+ (let ((prefixes (get-keyword #:prefix args #f)))
+ (if prefixes
+ `(begin
+ ,@(map (lambda (name)
+ `(define-extended-generic ,name
+ (list ,@(map (lambda (prefix)
+ (symbol-append prefix name))
+ prefixes))))
+ names))
+ (goops-error "no prefixes supplied"))))
(define (make-generic . name)
(let ((name (and (pair? name) (car name))))
(let ((ans (if gws?
(let* ((sname (and name (make-setter-name name)))
(setters
- (apply append
- (map (lambda (gf)
+ (append-map (lambda (gf)
(if (is-a? gf <generic-with-setter>)
(list (ensure-generic (setter gf)
sname))
'()))
- gfs)))
+ gfs))
(es (make <extended-generic-with-setter>
#:name name
#:extends gfs
(make <generic> #:name name #:default old-definition))
(else (make <generic> #:name name)))))
-(define define-accessor
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp)))
- (cond ((not (symbol? name))
- (goops-error "bad accessor name: ~S" name))
- ((top-level-env? env)
- `(process-define-accessor ',name))
- (else
- `(define ,name (make-accessor ',name))))))))
-
-(define (process-define-accessor name)
- (let ((var (module-ensure-local-variable! (current-module) name)))
- (if (or (not var)
- (not (variable-bound? var))
- (is-a? (variable-ref var) <accessor>)
- (is-a? (variable-ref var) <extended-generic-with-setter>))
- ;; redefine if NAME isn't defined previously, or is another accessor
- (variable-set! var (make-accessor name))
- ;; otherwise try to upgrade the object to an accessor
- (variable-set! var (ensure-accessor (variable-ref var) name)))))
+;; same semantics as <generic>
+(define-macro (define-accessor name)
+ (if (not (symbol? name))
+ (goops-error "bad accessor name: ~S" name))
+ `(define ,name
+ (if (and (defined? ',name) (is-a? ,name <accessor>))
+ (make <accessor> #:name ',name)
+ (ensure-accessor (if (defined? ',name) ,name #f) ',name))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
;;; {Methods}
;;;
-(define define-method
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((head (cadr exp)))
- (if (not (pair? head))
- (goops-error "bad method head: ~S" head)
- (let ((gf (car head)))
- (cond ((and (pair? gf)
- (eq? (car gf) 'setter)
- (pair? (cdr gf))
- (symbol? (cadr gf))
- (null? (cddr gf)))
- ;; named setter method
- (let ((name (cadr gf)))
- (cond ((not (symbol? name))
- `(add-method! (setter ,name)
- (method ,(cdadr exp)
- ,@(cddr exp))))
- ((defined? name env)
- `(begin
- ;; *fixme* Temporary hack for the current
- ;; module system
- (if (not ,name)
- (define-accessor ,name))
- (add-method! (setter ,name)
- (method ,(cdadr exp)
- ,@(cddr exp)))))
- (else
- `(begin
- (define-accessor ,name)
- (add-method! (setter ,name)
- (method ,(cdadr exp)
- ,@(cddr exp))))))))
- ((not (symbol? gf))
- `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
- ((defined? gf env)
- `(begin
- ;; *fixme* Temporary hack for the current
- ;; module system
- (if (not ,gf)
- (define-generic ,gf))
- (add-method! ,gf
- (method ,(cdadr exp)
- ,@(cddr exp)))))
- (else
- `(begin
- (define-generic ,gf)
- (add-method! ,gf
- (method ,(cdadr exp)
- ,@(cddr exp))))))))))))
-
-(define (make-method specializers procedure)
- (make <method>
- #:specializers specializers
- #:procedure procedure))
-
-(define method
+(define-macro (define-method head . body)
+ (if (not (pair? head))
+ (goops-error "bad method head: ~S" head))
+ (let ((gf (car head)))
+ (cond ((and (pair? gf)
+ (eq? (car gf) 'setter)
+ (pair? (cdr gf))
+ (symbol? (cadr gf))
+ (null? (cddr gf)))
+ ;; named setter method
+ (let ((name (cadr gf)))
+ (cond ((not (symbol? name))
+ `(add-method! (setter ,name)
+ (method ,(cdr head) ,@body)))
+ (else
+ `(begin
+ (if (or (not (defined? ',name))
+ (not (is-a? ,name <accessor>)))
+ (define-accessor ,name))
+ (add-method! (setter ,name)
+ (method ,(cdr head) ,@body)))))))
+ ((not (symbol? gf))
+ `(add-method! ,gf (method ,(cdr head) ,@body)))
+ (else
+ `(begin
+ ;; FIXME: this code is how it always was, but it's quite
+ ;; cracky: it will only define the generic function if it
+ ;; was undefined before (ok), or *was defined to #f*. The
+ ;; latter is crack. But there are bootstrap issues about
+ ;; fixing this -- change it to (is-a? ,gf <generic>) and
+ ;; see.
+ (if (or (not (defined? ',gf))
+ (not ,gf))
+ (define-generic ,gf))
+ (add-method! ,gf
+ (method ,(cdr head) ,@body)))))))
+
+(define-macro (method args . body)
(letrec ((specializers
(lambda (ls)
(cond ((null? ls) (list (list 'quote '())))
(cons (if (pair? (car ls)) (caar ls) (car ls))
(formals (cdr ls)))
ls))))
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((args (cadr exp))
- (body (cddr exp)))
- `(make <method>
- #:specializers (cons* ,@(specializers args))
- #:procedure (lambda ,(formals args)
- ,@(if (null? body)
- (list *unspecified*)
- body))))))))
+ (let ((make-proc (compile-make-procedure (formals args)
+ (specializers args)
+ body)))
+ `(make <method>
+ #:specializers (cons* ,@(specializers args))
+ #:formals ',(formals args)
+ #:body ',body
+ #:make-procedure ,make-proc
+ #:procedure ,(and (not make-proc)
+ ;; that is to say: we set #:procedure if
+ ;; `compile-make-procedure' returned `#f',
+ ;; which is the case if `body' does not
+ ;; contain a call to `next-method'
+ `(lambda ,(formals args)
+ ,@(if (null? body)
+ '((begin))
+ body)))))))
;;;
;;; {add-method!}
;; Add method in all the classes which appears in its specializers list
(for-each* (lambda (x)
(let ((dm (class-direct-methods x)))
- (if (not (memv m dm))
+ (if (not (memq m dm))
(slot-set! x 'direct-methods (cons m dm)))))
(method-specializers m)))
methods)
(loop (cdr l)))))))
-(define (internal-add-method! gf m)
- (slot-set! m 'generic-function gf)
- (slot-set! gf 'methods (compute-new-list-of-methods gf m))
- (let ((specializers (slot-ref m 'specializers)))
- (slot-set! gf 'n-specialized
- (max (length* specializers)
- (slot-ref gf 'n-specialized))))
- (%invalidate-method-cache! gf)
- (add-method-in-classes! m)
- *unspecified*)
+(define internal-add-method!
+ (method ((gf <generic>) (m <method>))
+ (slot-set! m 'generic-function gf)
+ (slot-set! gf 'methods (compute-new-list-of-methods gf m))
+ (let ((specializers (slot-ref m 'specializers)))
+ (slot-set! gf 'n-specialized
+ (max (length* specializers)
+ (slot-ref gf 'n-specialized))))
+ (%invalidate-method-cache! gf)
+ (add-method-in-classes! m)
+ *unspecified*))
(define-generic add-method!)
-(internal-add-method! add-method!
- (make <method>
- #:specializers (list <generic> <method>)
- #:procedure internal-add-method!))
+((method-procedure internal-add-method!) add-method! internal-add-method!)
(define-method (add-method! (proc <procedure>) (m <method>))
(if (generic-capability? proc)
(define-method (eqv? x y) #f)
(define-method (equal? x y) (eqv? x y))
-;;; These following two methods are for backward compatibility only.
-;;; They are not called by the Guile interpreter.
-;;;
-(define-method (object-eqv? x y) #f)
-(define-method (object-equal? x y) (eqv? x y))
-
;;;
;;; methods to display/write an object
;;;
(procedure-environment proc)))
(lambda (o) (assert-bound (proc o) o)))))
-(define n-standard-accessor-methods 10)
-
-(define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
-(define standard-get-methods (make-vector n-standard-accessor-methods #f))
-(define standard-set-methods (make-vector n-standard-accessor-methods #f))
-
-(define (standard-accessor-method make methods)
- (lambda (index)
- (cond ((>= index n-standard-accessor-methods) (make index))
- ((vector-ref methods index))
- (else (let ((m (make index)))
- (vector-set! methods index m)
- m)))))
-
-(define (make-bound-check-get index)
- (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))
-
-(define (make-get index)
- (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))
+;; the idea is to compile the index into the procedure, for fastest
+;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
+
+(eval-when (compile)
+ (use-modules ((language scheme compile-ghil) :select (define-scheme-translator))
+ ((language ghil) :select (make-ghil-inline make-ghil-call))
+ (system base pmatch))
+
+ ;; unfortunately, can't use define-inline because these are primitive
+ ;; syntaxen.
+ (define-scheme-translator @slot-ref
+ ((,obj ,index) (guard (integer? index)
+ (>= index 0) (< index max-fixnum))
+ (make-ghil-inline #f #f 'slot-ref
+ (list (retrans obj) (retrans index))))
+ (else
+ (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))
+
+ (define-scheme-translator @slot-set!
+ ((,obj ,index ,val) (guard (integer? index)
+ (>= index 0) (< index max-fixnum))
+ (make-ghil-inline #f #f 'slot-set
+ (list (retrans obj) (retrans index) (retrans val))))
+ (else
+ (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))
+
+(eval-when (eval load compile)
+ (define num-standard-pre-cache 20))
+
+(define-macro (define-standard-accessor-method form . body)
+ (let ((name (caar form))
+ (n-var (cadar form))
+ (args (cdr form)))
+ (define (make-one x)
+ (define (body-trans form)
+ (cond ((not (pair? form)) form)
+ ((eq? (car form) '@slot-ref)
+ `(,(car form) ,(cadr form) ,x))
+ ((eq? (car form) '@slot-set!)
+ `(,(car form) ,(cadr form) ,x ,(cadddr form)))
+ (else
+ (map body-trans form))))
+ `(lambda ,args ,@(map body-trans body)))
+ `(define ,name
+ (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
+ (lambda (n)
+ (if (< n ,num-standard-pre-cache)
+ (vector-ref cache n)
+ ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
+
+(define-standard-accessor-method ((bound-check-get n) o)
+ (let ((x (@slot-ref o n)))
+ (if (unbound? x)
+ (slot-unbound obj)
+ x)))
-(define (make-set index)
- (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))
+(define-standard-accessor-method ((standard-get n) o)
+ (@slot-ref o n))
-(define bound-check-get
- (standard-accessor-method make-bound-check-get bound-check-get-methods))
-(define standard-get (standard-accessor-method make-get standard-get-methods))
-(define standard-set (standard-accessor-method make-set standard-set-methods))
+(define-standard-accessor-method ((standard-set n) o v)
+ (@slot-set! o n v))
;;; compute-getters-n-setters
;;;
(else
(let ((get (car l))
(set (cadr l)))
- (if (not (and (closure? get)
- (= (car (procedure-property get 'arity)) 1)))
+ ;; note that we allow non-closures; we only check arity on
+ ;; the closures, though, because we inline their dispatch
+ ;; in %get-slot-value / %set-slot-value.
+ (if (or (not (procedure? get))
+ (and (closure? get)
+ (not (= (car (procedure-property get 'arity)) 1))))
(goops-error "Bad getter closure for slot `~S' in ~S: ~S"
slot class get))
- (if (not (and (closure? set)
- (= (car (procedure-property set 'arity)) 2)))
+ (if (or (not (procedure? set))
+ (and (closure? set)
+ (not (= (car (procedure-property set 'arity)) 2))))
(goops-error "Bad setter closure for slot `~S' in ~S: ~S"
slot class set))))))
(name (get-keyword #:name initargs #f)))
(next-method)
(slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
- (list (make <method>
- #:specializers <top>
- #:procedure
- (lambda l
- (apply previous-definition
- l))))
+ (list (method args
+ (apply previous-definition args)))
'()))
(if name
(set-procedure-property! generic 'name name))
(slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
(slot-set! method 'procedure
- (get-keyword #:procedure initargs dummy-procedure))
- (slot-set! method 'code-table '()))
+ (get-keyword #:procedure initargs #f))
+ (slot-set! method 'code-table '())
+ (slot-set! method 'formals (get-keyword #:formals initargs '()))
+ (slot-set! method 'body (get-keyword #:body initargs '()))
+ (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
+
(define-method (initialize (obj <foreign-object>) initargs))
AUTOMAKE_OPTIONS = gnu
-# These should be installed and distributed.
-goops_sources = \
+modpath = oop/goops
+SOURCES = \
active-slot.scm compile.scm composite-slot.scm describe.scm \
dispatch.scm internal.scm save.scm stklos.scm util.scm \
- old-define-method.scm accessors.scm simple.scm
+ accessors.scm simple.scm
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/oop/goops
-subpkgdata_DATA = $(goops_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(goops_sources)
+include $(top_srcdir)/am/guilec
--- /dev/null
+;;;; Copyright (C) 1999, 2000, 2005, 2006 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
+;;;;
+\f
+
+(define-module (oop goops accessors)
+ :use-module (oop goops)
+ :re-export (standard-define-class)
+ :export (define-class-with-accessors
+ define-class-with-accessors-keywords))
+
+(define-macro (define-class-with-accessors name supers . slots)
+ (let ((eat? #f))
+ `(standard-define-class
+ ,name ,supers
+ ,@(map-in-order
+ (lambda (slot)
+ (cond (eat?
+ (set! eat? #f)
+ slot)
+ ((keyword? slot)
+ (set! eat? #t)
+ slot)
+ ((pair? slot)
+ (if (get-keyword #:accessor (cdr slot) #f)
+ slot
+ (let ((name (car slot)))
+ `(,name #:accessor ,name ,@(cdr slot)))))
+ (else
+ `(,slot #:accessor ,slot))))
+ slots))))
+
+(define-macro (define-class-with-accessors-keywords name supers . slots)
+ (let ((eat? #f))
+ `(standard-define-class
+ ,name ,supers
+ ,@(map-in-order
+ (lambda (slot)
+ (cond (eat?
+ (set! eat? #f)
+ slot)
+ ((keyword? slot)
+ (set! eat? #t)
+ slot)
+ ((pair? slot)
+ (let ((slot
+ (if (get-keyword #:accessor (cdr slot) #f)
+ slot
+ (let ((name (car slot)))
+ `(,name #:accessor ,name ,@(cdr slot))))))
+ (if (get-keyword #:init-keyword (cdr slot) #f)
+ slot
+ (let* ((name (car slot))
+ (keyword (symbol->keyword name)))
+ `(,name #:init-keyword ,keyword ,@(cdr slot))))))
+ (else
+ `(,slot #:accessor ,slot
+ #:init-keyword ,(symbol->keyword slot)))))
+ slots))))
--- /dev/null
+;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+\f
+
+;; There are circularities here; you can't import (oop goops compile)
+;; before (oop goops). So when compiling, make sure that things are
+;; kosher.
+(eval-when (compile) (resolve-module '(oop goops)))
+
+(define-module (oop goops compile)
+ :use-module (oop goops)
+ :use-module (oop goops util)
+ :export (compute-cmethod compile-make-procedure)
+ :no-backtrace
+ )
+
+;;;
+;;; Method entries
+;;;
+
+(define code-table-lookup
+ (letrec ((check-entry (lambda (entry types)
+ (if (null? types)
+ (and (not (struct? (car entry)))
+ entry)
+ (and (eq? (car entry) (car types))
+ (check-entry (cdr entry) (cdr types)))))))
+ (lambda (code-table types)
+ (cond ((null? code-table) #f)
+ ((check-entry (car code-table) types))
+ (else (code-table-lookup (cdr code-table) types))))))
+
+(define (compute-cmethod methods types)
+ (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
+ (let* ((method (car methods))
+ (cmethod (compile-method methods types))
+ (entry (append types cmethod)))
+ (slot-set! method 'code-table
+ (cons entry (slot-ref method 'code-table)))
+ cmethod)))
+
+;;;
+;;; Compiling next methods into method bodies
+;;;
+
+;;; So, for the reader: there basic idea is that, given that the
+;;; semantics of `next-method' depend on the concrete types being
+;;; dispatched, why not compile a specific procedure to handle each type
+;;; combination that we see at runtime. There are two compilation
+;;; strategies implemented: one for the memoizer, and one for the VM
+;;; compiler.
+;;;
+;;; In theory we can do much better than a bytecode compilation, because
+;;; we know the *exact* types of the arguments. It's ideal for native
+;;; compilation. A task for the future.
+;;;
+;;; I think this whole generic application mess would benefit from a
+;;; strict MOP.
+
+;;; Temporary solution---return #f if x doesn't refer to `next-method'.
+(define (next-method? x)
+ (and (pair? x)
+ (or (eq? (car x) 'next-method)
+ (next-method? (car x))
+ (next-method? (cdr x)))))
+
+;; Called by the `method' macro in goops.scm.
+(define (compile-make-procedure formals specializers body)
+ (and (next-method? body)
+ (let ((next-method-sym (gensym " next-method"))
+ (args-sym (gensym)))
+ `(lambda (,next-method-sym)
+ (lambda ,formals
+ (let ((next-method (lambda ,args-sym
+ (if (null? ,args-sym)
+ ,(if (list? formals)
+ `(,next-method-sym ,@formals)
+ `(apply
+ ,next-method-sym
+ ,@(improper->proper formals)))
+ (apply ,next-method-sym ,args-sym)))))
+ ,@(if (null? body)
+ '((begin))
+ body)))))))
+
+(define (compile-method methods types)
+ (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
+ (if make-procedure
+ (make-procedure
+ (if (null? methods)
+ (lambda args
+ (no-next-method (method-generic-function (car methods)) args))
+ (compute-cmethod (cdr methods) types)))
+ (method-procedure (car methods)))))
;;;;
\f
+;; There are circularities here; you can't import (oop goops compile)
+;; before (oop goops). So when compiling, make sure that things are
+;; kosher.
+(eval-when (compile) (resolve-module '(oop goops)))
+
(define-module (oop goops dispatch)
:use-module (oop goops)
:use-module (oop goops util)
(define (cache-methods entries)
(do ((i (- (vector-length entries) 1) (- i 1))
(methods '() (let ((entry (vector-ref entries i)))
- (if (struct? (car entry))
+ (if (or (not (pair? entry)) (struct? (car entry)))
(cons entry methods)
methods))))
((< i 0) methods)))
(let ((hashset-index (+ hashset-index hashset)))
(do ((sum 0)
(classes entry (cdr classes)))
- ((not (struct? (car classes))) sum)
+ ((not (and (pair? classes) (struct? (car classes))))
+ sum)
(set! sum (+ sum (struct-ref (car classes) hashset-index))))))
+;;; FIXME: the throw probably is expensive, given that this function
+;;; might be called an average of 3 or 4 times per rehash...
(define (cache-try-hash! min-misses hashset cache entries)
(let ((max-misses 0)
(mask (- (vector-length cache) 1)))
((null? ls) max-misses)
(do ((i (logand mask (cache-hashval hashset (car ls)))
(logand mask (+ i 1))))
- ((not (struct? (car (vector-ref cache i))))
+ ((and (pair? (vector-ref cache i))
+ (eq? (car (vector-ref cache i)) 'no-method))
(vector-set! cache i (car ls)))
(set! misses (+ 1 misses))
(if (>= misses min-misses)
(+ 1 (slot-ref (method-cache-generic-function exp)
'n-specialized)))))
(let* ((types (map class-of (first-n args n-specializers)))
- (entry+cmethod (compute-entry-with-cmethod applicable types)))
- (insert! exp (car entry+cmethod)) ; entry = types + cmethod
- (cdr entry+cmethod) ; cmethod
- )))))
+ (cmethod (compute-cmethod applicable types)))
+ (insert! exp (append types cmethod)) ; entry = types + cmethod
+ cmethod))))) ; cmethod
(not readables))
(define readables (make-weak-key-hash-table 61)))
-(define readable
- (procedure->memoizing-macro
- (lambda (exp env)
- `(make-readable ,(cadr exp) ',(copy-tree (cadr exp))))))
+(define-macro (readable exp)
+ `(make-readable ,exp ',(copy-tree exp)))
(define (make-readable obj expr)
(hashq-set! readables obj expr)
(class-slots class)
(slot-ref class 'getters-n-setters)))
-(define restore
- (procedure->memoizing-macro
- (lambda (exp env)
- "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
- `(let ((o (,%allocate-instance ,(cadr exp) '())))
- (for-each (lambda (name val)
- (,slot-set! o name val))
- ',(caddr exp)
- (list ,@(cdddr exp)))
- o))))
+(define-macro (restore class slots . exps)
+ "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
+ `(let ((o ((@@ (oop goops) %allocate-instance) ,class '())))
+ (for-each (lambda (name val)
+ (slot-set! o name val))
+ ',slots
+ (list ,@exps))
+ o))
(define-method (enumerate! (o <object>) env)
(get-set-for-each (lambda (get set)
;;; write-component OBJECT PATCHER FILE ENV
;;;
-(define write-component
- (procedure->memoizing-macro
- (lambda (exp env)
- `(or (write-component-procedure ,(cadr exp) ,@(cdddr exp))
- (begin
- (display #f ,(cadddr exp))
- (add-patcher! ,(caddr exp) env))))))
+(define-macro (write-component object patcher file env)
+ `(or (write-component-procedure ,object ,file ,env)
+ (begin
+ (display #f ,file)
+ (add-patcher! ,patcher ,env))))
;;;
;;; Main engine
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc.
+##
+## This file is part of GUILE.
+##
+## GUILE 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.
+##
+## GUILE 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 GUILE; see the file COPYING. If not, write
+## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+## Floor, Boston, MA 02110-1301 USA
+
+AUTOMAKE_OPTIONS = gnu
+
+modpath = srfi
+SOURCES = \
+ srfi-1.scm \
+ srfi-2.scm \
+ srfi-4.scm \
+ srfi-6.scm \
+ srfi-8.scm \
+ srfi-9.scm \
+ srfi-10.scm \
+ srfi-11.scm \
+ srfi-13.scm \
+ srfi-14.scm \
+ srfi-16.scm \
+ srfi-17.scm \
+ srfi-19.scm \
+ srfi-26.scm \
+ srfi-31.scm \
+ srfi-34.scm \
+ srfi-35.scm \
+ srfi-37.scm \
+ srfi-39.scm \
+ srfi-60.scm \
+ srfi-69.scm \
+ srfi-88.scm
+
+# Will poke this later.
+NOCOMP_SOURCES = srfi-18.scm
+
+include $(top_srcdir)/am/guilec
(63072000 . 10)))
(define (read-leap-second-table filename)
- (set! priv:leap-second-table (priv:read-tai-utc-data filename))
- (values))
+ (set! priv:leap-second-table (priv:read-tai-utc-data filename)))
(define (priv:leap-second-delta utc-seconds)
(if associated (cdr associated) #f)))
(define (priv:date-printer date index format-string str-len port)
- (if (>= index str-len)
- (values)
+ (if (< index str-len)
(let ((current-char (string-ref format-string index)))
(if (not (char=? current-char #\~))
(begin
;; for input,
;; 3. a port reader procedure that knows how to read the current port
;; for a value. Its one parameter is the port.
-;; 4. a action procedure, that takes the value (from 3.) and some
-;; object (here, always the date) and (probably) side-effects it.
-;; In some cases (e.g., ~A) the action is to do nothing
+;; 4. an optional action procedure, that takes the value (from 3.) and
+;; some object (here, always the date) and (probably) side-effects it.
+;; If no action is required, as with ~A, this element may be #f.
(define priv:read-directives
(let ((ireader4 (priv:make-integer-reader 4))
priv:locale-abbr-month->index))
(locale-reader-long-month (priv:make-locale-reader
priv:locale-long-month->index))
- (char-fail (lambda (ch) #t))
- (do-nothing (lambda (val object) (values))))
+ (char-fail (lambda (ch) #t)))
(list
- (list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing)
- (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
- (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)
+ (list #\~ char-fail (priv:make-char-id-reader #\~) #f)
+ (list #\a char-alphabetic? locale-reader-abbr-weekday #f)
+ (list #\A char-alphabetic? locale-reader-long-weekday #f)
(list #\b char-alphabetic? locale-reader-abbr-month
(lambda (val object)
(set-date-month! object val)))
(priv:time-error 'string->date 'bad-date-format-string template-string)
(if (not (skipper ch))
(begin (read-char port) (skip-until port skipper))))))
- (if (>= index str-len)
- (begin
- (values))
+ (if (< index str-len)
(let ((current-char (string-ref format-string index)))
(if (not (char=? current-char #\~))
(let ((port-char (read-char port)))
(priv:time-error 'string->date
'bad-date-format-string
template-string)
- (actor val date)))
+ (if actor (actor val date))))
(priv:string->date date
(+ index 2)
format-string
(cond-expand-provide (current-module) '(srfi-37))
\f
+;;;; Internal helper macros
+
+;; Define these first, so the compiler will pick them up.
+
+;; I am a macro only for efficiency, to avoid varargs/apply.
+(define-macro (hashx-invoke hashx-proc ht-var . args)
+ "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function,
+assoc-function, and the hash-table as first args."
+ `(,hashx-proc (hash-table-hash-function ,ht-var)
+ (ht-associator ,ht-var)
+ (ht-real-table ,ht-var)
+ . ,args))
+
+(define-macro (with-hashx-values bindings ht-var . body-forms)
+ "Bind BINDINGS to the hash-function, associator, and real-table of
+HT-VAR, while evaluating BODY-FORMS."
+ `(let ((,(first bindings) (hash-table-hash-function ,ht-var))
+ (,(second bindings) (ht-associator ,ht-var))
+ (,(third bindings) (ht-real-table ,ht-var)))
+ . ,body-forms))
+
+\f
;;;; Hashing
;;; The largest fixnum is in `most-positive-fixnum' in module (guile),
;; possible collision with *unspecified*.
(define ht-unspecified (cons *unspecified* "ht-value"))
-;; I am a macro only for efficiency, to avoid varargs/apply.
-(define-macro (hashx-invoke hashx-proc ht-var . args)
- "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function,
-assoc-function, and the hash-table as first args."
- `(,hashx-proc (hash-table-hash-function ,ht-var)
- (ht-associator ,ht-var)
- (ht-real-table ,ht-var)
- . ,args))
-
-(define-macro (with-hashx-values bindings ht-var . body-forms)
- "Bind BINDINGS to the hash-function, associator, and real-table of
-HT-VAR, while evaluating BODY-FORMS."
- `(let ((,(first bindings) (hash-table-hash-function ,ht-var))
- (,(second bindings) (ht-associator ,ht-var))
- (,(third bindings) (ht-real-table ,ht-var)))
- . ,body-forms))
-
(define (hash-table-ref ht key . default-thunk-lst)
"Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY
isn't present, or signal an error if DEFAULT-THUNK isn't provided."
(define (hash-table-walk ht proc)
"Call PROC with each key and value as two arguments."
- (hash-table-fold ht (lambda (k v unspec) (proc k v) unspec)
+ (hash-table-fold ht (lambda (k v unspec)
+ (call-with-values (lambda () (proc k v))
+ (lambda vals unspec)))
*unspecified*))
(define (hash-table-fold ht f knil)
--- /dev/null
+;;; High-level compiler interface
+
+;; Copyright (C) 2001, 2009 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-module (system base syntax)
+ #:use-module (system base language)
+ #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 optargs)
+ #:use-module (ice-9 receive)
+ #:export (syntax-error
+ *current-language*
+ compiled-file-name compile-file compile-and-load
+ compile compile-time-environment
+ decompile)
+ #:export-syntax (call-with-compile-error-catch))
+
+;;;
+;;; 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)
+ (let ((file (or (assq-ref loc 'filename) "unknown file"))
+ (line (assq-ref loc 'line))
+ (col (assq-ref loc 'column)))
+ (format (current-error-port)
+ "~A:~A:~A: ~A: ~A~%" file line col msg exp))
+ (format (current-error-port)
+ "unknown location: ~A: ~S~%" msg exp)))))
+
+\f
+;;;
+;;; Compiler
+;;;
+
+(define *current-language* (make-fluid))
+(fluid-set! *current-language* 'scheme)
+(define (current-language)
+ (fluid-ref *current-language*))
+
+(define (call-once thunk)
+ (let ((entered #f))
+ (dynamic-wind
+ (lambda ()
+ (if entered
+ (error "thunk may only be entered once: ~a" thunk))
+ (set! entered #t))
+ thunk
+ (lambda () #t))))
+
+(define (call-with-output-file/atomic filename proc)
+ (let* ((template (string-append filename ".XXXXXX"))
+ (tmp (mkstemp! template)))
+ (call-once
+ (lambda ()
+ (with-throw-handler #t
+ (lambda ()
+ (proc tmp)
+ (chmod tmp (logand #o0666 (lognot (umask))))
+ (close-port tmp)
+ (rename-file template filename))
+ (lambda args
+ (delete-file template)))))))
+
+(define (ensure-language x)
+ (if (language? x)
+ x
+ (lookup-language x)))
+
+(define* (compile-file file #:optional output-file
+ #:key (to 'objcode) (opts '()))
+ (let ((comp (or output-file (compiled-file-name file)))
+ (lang (ensure-language (current-language)))
+ (to (ensure-language to)))
+ (catch 'nothing-at-all
+ (lambda ()
+ (call-with-compile-error-catch
+ (lambda ()
+ (call-with-output-file/atomic comp
+ (lambda (port)
+ (let ((print (language-printer to)))
+ (print (compile (read-file-in file lang)
+ #:from lang #:to to #:opts opts)
+ 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)))))
+
+(define* (compile-and-load file #:key (to 'value) (opts '()))
+ (let ((lang (ensure-language (current-language))))
+ (compile (read-file-in file lang) #:to 'value #:opts opts)))
+
+(define (compiled-file-name file)
+ (let ((base (basename file))
+ (cext (cond ((or (null? %load-compiled-extensions)
+ (string-null? (car %load-compiled-extensions)))
+ (warn "invalid %load-compiled-extensions"
+ %load-compiled-extensions)
+ ".go")
+ (else (car %load-compiled-extensions)))))
+ (let lp ((exts %load-extensions))
+ (cond ((null? exts) (string-append file cext))
+ ((string-null? (car exts)) (lp (cdr exts)))
+ ((string-suffix? (car exts) base)
+ (string-append
+ (dirname file) "/"
+ (substring base 0
+ (- (string-length base) (string-length (car exts))))
+ cext))
+ (else (lp (cdr exts)))))))
+
+\f
+;;;
+;;; Compiler interface
+;;;
+
+(define (read-file-in file lang)
+ (call-with-input-file file
+ (or (language-read-file lang)
+ (error "language has no #:read-file" lang))))
+
+(define (compile-passes from to opts)
+ (map cdr
+ (or (lookup-compilation-order from to)
+ (error "no way to compile" from "to" to))))
+
+(define (compile-fold passes exp env opts)
+ (if (null? passes)
+ exp
+ (receive (exp env) ((car passes) exp env opts)
+ (compile-fold (cdr passes) exp env opts))))
+
+(define (compile-time-environment)
+ "A special function known to the compiler that, when compiled, will
+return a representation of the lexical environment in place at compile
+time. Useful for supporting some forms of dynamic compilation. Returns
+#f if called from the interpreter."
+ #f)
+
+(define* (compile x #:key
+ (env #f)
+ (from (current-language))
+ (to 'value)
+ (opts '()))
+ (compile-fold (compile-passes from to opts)
+ x
+ env
+ opts))
+
+\f
+;;;
+;;; Decompiler interface
+;;;
+
+(define (decompile-passes from to opts)
+ (map cdr
+ (or (lookup-decompilation-order from to)
+ (error "no way to decompile" from "to" to))))
+
+(define (decompile-fold passes exp env opts)
+ (if (null? passes)
+ (values exp env)
+ (receive (exp env) ((car passes) exp env opts)
+ (decompile-fold (cdr passes) exp env opts))))
+
+(define* (decompile x #:key
+ (env #f)
+ (from 'value)
+ (to 'assembly)
+ (opts '()))
+ (decompile-fold (decompile-passes from to opts)
+ x
+ env
+ opts))
--- /dev/null
+;;; Multi-language support
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system base language)
+ #:use-module (system base syntax)
+ #:export (define-language language? lookup-language make-language
+ language-name language-title language-version language-reader
+ language-printer language-parser language-read-file
+ language-compilers language-decompilers language-evaluator
+
+ lookup-compilation-order lookup-decompilation-order
+ invalidate-compilation-cache!))
+
+\f
+;;;
+;;; Language class
+;;;
+
+(define-record/keywords <language>
+ name
+ title
+ version
+ reader
+ printer
+ (parser #f)
+ (read-file #f)
+ (compilers '())
+ (decompilers '())
+ (evaluator #f))
+
+(define-macro (define-language name . spec)
+ `(begin
+ (invalidate-compilation-cache!)
+ (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))))
+
+(define *compilation-cache* '())
+(define *decompilation-cache* '())
+
+(define (invalidate-compilation-cache!)
+ (set! *decompilation-cache* '())
+ (set! *compilation-cache* '()))
+
+(define (compute-translation-order from to language-translators)
+ (cond
+ ((not (language? to))
+ (compute-translation-order from (lookup-language to) language-translators))
+ (else
+ (let lp ((from from) (seen '()))
+ (cond
+ ((not (language? from))
+ (lp (lookup-language from) seen))
+ ((eq? from to) (reverse! seen))
+ ((memq from seen) #f)
+ (else (or-map (lambda (pair)
+ (lp (car pair) (acons from (cdr pair) seen)))
+ (language-translators from))))))))
+
+(define (lookup-compilation-order from to)
+ (let ((key (cons from to)))
+ (or (assoc-ref *compilation-cache* key)
+ (let ((order (compute-translation-order from to language-compilers)))
+ (set! *compilation-cache*
+ (acons key order *compilation-cache*))
+ order))))
+
+(define (lookup-decompilation-order from to)
+ (let ((key (cons from to)))
+ (or (assoc-ref *decompilation-cache* key)
+ ;; trickery!
+ (let ((order (and=>
+ (compute-translation-order to from language-decompilers)
+ reverse!)))
+ (set! *decompilation-cache* (acons key order *decompilation-cache*))
+ order))))
--- /dev/null
+(define-module (system base pmatch)
+ #:use-module (ice-9 syncase)
+ #:export (pmatch ppat))
+;; FIXME: shouldn't have to export ppat...
+
+;; Originally written by Oleg Kiselyov. Taken from:
+;; αKanren: A Fresh Name in Nominal Logic Programming
+;; by William E. Byrd and Daniel P. Friedman
+;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
+;; Université Laval Technical Report DIUL-RT-0701
+
+;; Licensing unclear. Probably need to ask Oleg for a disclaimer.
+
+(define-syntax pmatch
+ (syntax-rules (else guard)
+ ((_ (op arg ...) cs ...)
+ (let ((v (op arg ...)))
+ (pmatch v cs ...)))
+ ((_ v) (if #f #f))
+ ((_ v (else e0 e ...)) (begin e0 e ...))
+ ((_ v (pat (guard g ...) e0 e ...) cs ...)
+ (let ((fk (lambda () (pmatch v cs ...))))
+ (ppat v pat
+ (if (and g ...) (begin e0 e ...) (fk))
+ (fk))))
+ ((_ v (pat e0 e ...) cs ...)
+ (let ((fk (lambda () (pmatch v cs ...))))
+ (ppat v pat (begin e0 e ...) (fk))))))
+
+(define-syntax ppat
+ (syntax-rules (_ quote unquote)
+ ((_ v _ kt kf) kt)
+ ((_ v () kt kf) (if (null? v) kt kf))
+ ((_ v (quote lit) kt kf)
+ (if (equal? v (quote lit)) kt kf))
+ ((_ v (unquote var) kt kf) (let ((var v)) kt))
+ ((_ v (x . y) kt kf)
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (ppat vx x (ppat vy y kt kf) kf))
+ kf))
+ ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
--- /dev/null
+;;; Guile VM specific syntaxes and utilities
+
+;; Copyright (C) 2001 Free Software Foundation, Inc
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA
+
+;;; Code:
+
+(define-module (system base syntax)
+ #:export (%compute-initargs)
+ #:export-syntax (define-type define-record define-record/keywords
+ record-case transform-record))
+
+(define (symbol-trim-both sym pred)
+ (string->symbol (string-trim-both (symbol->string sym) pred)))
+(define (trim-brackets sym)
+ (symbol-trim-both sym (list->char-set '(#\< #\>))))
+
+\f
+;;;
+;;; Type
+;;;
+
+(define-macro (define-type name . rest)
+ (let ((name (if (pair? name) (car name) name))
+ (opts (if (pair? name) (cdr name) '())))
+ (let ((printer (kw-arg-ref opts #:printer))
+ (common-slots (or (kw-arg-ref opts #:common-slots) '())))
+ `(begin ,@(map (lambda (def)
+ `(define-record ,(if printer
+ `(,(car def) ,printer)
+ (car def))
+ ,@common-slots
+ ,@(cdr def)))
+ rest)
+ ,@(map (lambda (common-slot i)
+ `(define ,(symbol-append (trim-brackets name)
+ '- common-slot)
+ (make-procedure-with-setter
+ (lambda (x) (struct-ref x ,i))
+ (lambda (x v) (struct-set! x ,i v)))))
+ common-slots (iota (length common-slots)))))))
+
+
+;;;
+;;; Record
+;;;
+
+(define-macro (define-record name-form . slots)
+ (let* ((name (if (pair? name-form) (car name-form) name-form))
+ (printer (and (pair? name-form) (cadr name-form)))
+ (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+ slots))
+ (stem (trim-brackets name)))
+ `(begin
+ (define ,name (make-record-type ,(symbol->string name) ',slot-names
+ ,@(if printer (list printer) '())))
+ ,(let* ((reqs (let lp ((slots slots))
+ (if (or (null? slots) (not (symbol? (car slots))))
+ '()
+ (cons (car slots) (lp (cdr slots))))))
+ (opts (list-tail slots (length reqs)))
+ (tail (gensym)))
+ `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
+ (let ,(map (lambda (o)
+ `(,(car o) (cond ((null? ,tail) ,(cadr o))
+ (else (let ((_x (car ,tail)))
+ (set! ,tail (cdr ,tail))
+ _x)))))
+ opts)
+ (make-struct ,name 0 ,@slot-names))))
+ (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))))
+
+;; like the former, but accepting keyword arguments in addition to
+;; optional arguments
+(define-macro (define-record/keywords name-form . slots)
+ (let* ((name (if (pair? name-form) (car name-form) name-form))
+ (printer (and (pair? name-form) (cadr name-form)))
+ (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+ slots))
+ (stem (trim-brackets name)))
+ `(begin
+ (define ,name (make-record-type ,(symbol->string name) ',slot-names
+ ,@(if printer (list printer) '())))
+ (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)
+ (let ((slot (car positional)))
+ (acons (if (pair? slot) (car slot) slot)
+ (car in)
+ out)))))))
+
+;; So, dear reader. It is pleasant indeed around this fire or at this
+;; cafe or in this room, is it not? I think so too.
+;;
+;; This macro used to generate code that looked like this:
+;;
+;; `(((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)))))
+;;
+;; But this was a hot spot, so computing all those predicates and
+;; accessors all the time was getting expensive, so we did a terrible
+;; thing: we decided that since above we're already defining accessors
+;; and predicates with computed names, we might as well just rely on that fact here.
+;;
+;; It's a bit nasty, I agree. But it is fast.
+;;
+;;scheme@(guile-user)> (with-statprof #:hz 1000 #:full-stacks? #t (resolve-module '(oop goops)))% cumulative self
+;; time seconds seconds name
+;; 8.82 0.03 0.01 glil->assembly
+;; 8.82 0.01 0.01 record-type-fields
+;; 5.88 0.01 0.01 %compute-initargs
+;; 5.88 0.01 0.01 list-index
+
+
+(define-macro (record-case record . clauses)
+ (let ((r (gensym))
+ (rtd (gensym)))
+ (define (process-clause clause)
+ (if (eq? (car clause) 'else)
+ clause
+ (let ((record-type (caar clause))
+ (slots (cdar clause))
+ (body (cdr clause)))
+ (let ((stem (trim-brackets record-type)))
+ `((eq? ,rtd ,record-type)
+ (let ,(map (lambda (slot)
+ (if (pair? slot)
+ `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
+ `(,slot (,(symbol-append stem '- slot) ,r))))
+ slots)
+ ,@(if (pair? body) body '((if #f #f)))))))))
+ `(let* ((,r ,record)
+ (,rtd (struct-vtable ,r)))
+ (cond ,@(let ((clauses (map process-clause clauses)))
+ (if (assq 'else clauses)
+ clauses
+ (append clauses `((else (error "unhandled record" ,r))))))))))
+
+;; Here we take the terrorism to another level. Nasty, but the client
+;; code looks good.
+
+(define-macro (transform-record type-and-common record . clauses)
+ (let ((r (gensym))
+ (rtd (gensym))
+ (type-stem (trim-brackets (car type-and-common))))
+ (define (make-stem s)
+ (symbol-append type-stem '- s))
+ (define (further-predicates x record-stem slots)
+ (define (access slot)
+ `(,(symbol-append (make-stem record-stem) '- slot) ,x))
+ (let lp ((in slots) (out '()))
+ (cond ((null? in) out)
+ ((pair? (car in))
+ (let ((slot (caar in))
+ (arg (cadar in)))
+ (cond ((symbol? arg)
+ (lp (cdr in) out))
+ ((pair? arg)
+ (lp (cdr in)
+ (append (further-predicates (access slot)
+ (car arg)
+ (cdr arg))
+ out)))
+ (else (lp (cdr in) (cons `(eq? ,(access slot) ',arg)
+ out))))))
+ (else (lp (cdr in) out)))))
+ (define (let-clauses x record-stem slots)
+ (define (access slot)
+ `(,(symbol-append (make-stem record-stem) '- slot) ,x))
+ (let lp ((in slots) (out '()))
+ (cond ((null? in) out)
+ ((pair? (car in))
+ (let ((slot (caar in))
+ (arg (cadar in)))
+ (cond ((symbol? arg)
+ (lp (cdr in)
+ (cons `(,arg ,(access slot)) out)))
+ ((pair? arg)
+ (lp (cdr in)
+ (append (let-clauses (access slot)
+ (car arg)
+ (cdr arg))
+ out)))
+ (else
+ (lp (cdr in) out)))))
+ (else
+ (lp (cdr in)
+ (cons `(,(car in) ,(access (car in))) out))))))
+ (define (transform-expr x)
+ (cond ((not (pair? x)) x)
+ ((eq? (car x) '->)
+ (if (= (length x) 2)
+ (let ((form (cadr x)))
+ `(,(symbol-append 'make- (make-stem (car form)))
+ ,@(cdr type-and-common)
+ ,@(map (lambda (y)
+ (if (and (pair? y) (eq? (car y) 'unquote))
+ (transform-expr (cadr y))
+ y))
+ (cdr form))))
+ (error "bad -> form" x)))
+ (else (cons (car x) (map transform-expr (cdr x))))))
+ (define (process-clause clause)
+ (if (eq? (car clause) 'else)
+ clause
+ (let ((stem (caar clause))
+ (slots (cdar clause))
+ (body (cdr clause)))
+ (let ((record-type (symbol-append '< (make-stem stem) '>)))
+ `((and (eq? ,rtd ,record-type)
+ ,@(reverse (further-predicates r stem slots)))
+ (let ,(reverse (let-clauses r stem slots))
+ ,@(if (pair? body)
+ (map transform-expr body)
+ '((if #f #f)))))))))
+ `(let* ((,r ,record)
+ (,rtd (struct-vtable ,r))
+ ,@(map (lambda (slot)
+ `(,slot (,(make-stem slot) ,r)))
+ (cdr type-and-common)))
+ (cond ,@(let ((clauses (map process-clause clauses)))
+ (if (assq 'else clauses)
+ clauses
+ (append clauses `((else (error "unhandled record" ,r))))))))))
--- /dev/null
+;;; Repl commands
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl command)
+ #:use-syntax (system base syntax)
+ #:use-module (system base pmatch)
+ #:use-module (system base compile)
+ #:use-module (system repl common)
+ #:use-module (system vm objcode)
+ #:use-module (system vm program)
+ #:use-module (system vm vm)
+ #:autoload (system base language) (lookup-language)
+ #:autoload (system vm debug) (vm-debugger vm-backtrace)
+ #:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
+ #:autoload (system vm profile) (vm-profile)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 session)
+ #:use-module (ice-9 documentation)
+ #:use-module (ice-9 and-let-star)
+ #:export (meta-command))
+
+\f
+;;;
+;;; Meta command interface
+;;;
+
+(define *command-table*
+ '((help (help h) (apropos a) (describe d) (option o) (quit q))
+ (module (module m) (import i) (load l) (binding b))
+ (language (language L))
+ (compile (compile c) (compile-file cc)
+ (disassemble x) (disassemble-file xx))
+ (profile (time t) (profile pr))
+ (debug (backtrace bt) (debugger db) (trace tr) (step st))
+ (system (gc) (statistics stat))))
+
+(define (group-name g) (car g))
+(define (group-commands g) (cdr g))
+
+;; Hack, until core can be extended.
+(define procedure-documentation
+ (let ((old-definition procedure-documentation))
+ (lambda (p)
+ (if (program? p)
+ (program-documentation p)
+ (old-definition p)))))
+
+(define *command-module* (current-module))
+(define (command-name c) (car c))
+(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
+(define (command-procedure c) (module-ref *command-module* (command-name c)))
+(define (command-doc c) (procedure-documentation (command-procedure c)))
+
+(define (command-usage c)
+ (let ((doc (command-doc c)))
+ (substring doc 0 (string-index doc #\newline))))
+
+(define (command-summary c)
+ (let* ((doc (command-doc c))
+ (start (1+ (string-index doc #\newline))))
+ (cond ((string-index doc #\newline start)
+ => (lambda (end) (substring doc start end)))
+ (else (substring doc start)))))
+
+(define (lookup-group name)
+ (assq name *command-table*))
+
+(define (lookup-command key)
+ (let loop ((groups *command-table*) (commands '()))
+ (cond ((and (null? groups) (null? commands)) #f)
+ ((null? commands)
+ (loop (cdr groups) (cdar groups)))
+ ((memq key (car commands)) (car commands))
+ (else (loop groups (cdr commands))))))
+
+(define (display-group group . opts)
+ (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
+ (for-each (lambda (c)
+ (display-summary (command-usage c)
+ (command-abbrev c)
+ (command-summary c)))
+ (group-commands group))
+ (newline))
+
+(define (display-command command)
+ (display "Usage: ")
+ (display (command-doc command))
+ (newline))
+
+(define (display-summary usage abbrev summary)
+ (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
+ (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
+
+(define (meta-command repl line)
+ (let ((input (call-with-input-string (string-append "(" line ")") read)))
+ (if (not (null? input))
+ (do ((key (car input))
+ (args (cdr input) (cdr args))
+ (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
+ ((or (null? args)
+ (not (symbol? (car args)))
+ (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
+ (let ((c (lookup-command key)))
+ (if c
+ (cond ((memq #:h opts) (display-command c))
+ (else (apply (command-procedure c)
+ repl (append! args (reverse! opts)))))
+ (user-error "Unknown meta command: ~A" key))))))))
+
+\f
+;;;
+;;; Help commands
+;;;
+
+(define (help repl . args)
+ "help [GROUP]
+List available meta commands.
+A command group name can be given as an optional argument.
+Without any argument, a list of help commands and command groups
+are displayed, as you have already seen ;)"
+ (pmatch args
+ (()
+ (display-group (lookup-group 'help))
+ (display "Command Groups:\n\n")
+ (display-summary "help all" #f "List all commands")
+ (for-each (lambda (g)
+ (let* ((name (symbol->string (group-name g)))
+ (usage (string-append "help " name))
+ (header (string-append "List " name " commands")))
+ (display-summary usage #f header)))
+ (cdr *command-table*))
+ (newline)
+ (display "Type `,COMMAND -h' to show documentation of each command.")
+ (newline))
+ ((all)
+ (for-each display-group *command-table*))
+ ((,group) (guard (lookup-group group))
+ (display-group (lookup-group group)))
+ (else
+ (user-error "Unknown command group: ~A" (car args)))))
+
+(define guile:apropos apropos)
+(define (apropos repl regexp)
+ "apropos REGEXP
+Find bindings/modules/packages."
+ (guile:apropos (->string regexp)))
+
+(define (describe repl obj)
+ "describe OBJ
+Show description/documentation."
+ (display (object-documentation
+ (repl-eval repl (repl-parse repl obj))))
+ (newline))
+
+(define (option repl . args)
+ "option [KEY VALUE]
+List/show/set options."
+ (pmatch args
+ (()
+ (for-each (lambda (key+val)
+ (format #t "~A\t~A\n" (car key+val) (cdr key+val)))
+ (repl-options repl)))
+ ((,key)
+ (display (repl-option-ref repl key))
+ (newline))
+ ((,key ,val)
+ (repl-option-set! repl key val)
+ (case key
+ ((trace)
+ (let ((vm (repl-vm repl)))
+ (if val
+ (apply vm-trace-on vm val)
+ (vm-trace-off vm))))))))
+
+(define (quit repl)
+ "quit
+Quit this session."
+ (throw 'quit))
+
+\f
+;;;
+;;; Module commands
+;;;
+
+(define (module repl . args)
+ "module [MODULE]
+Change modules / Show current module."
+ (pmatch args
+ (() (puts (module-name (current-module))))
+ ((,mod-name) (guard (list? mod-name))
+ (set-current-module (resolve-module mod-name)))
+ (,mod-name (set-current-module (resolve-module mod-name)))))
+
+(define (import repl . args)
+ "import [MODULE ...]
+Import modules / List those imported."
+ (let ()
+ (define (use name)
+ (let ((mod (resolve-interface name)))
+ (if mod
+ (module-use! (current-module) mod)
+ (user-error "No such module: ~A" name))))
+ (if (null? args)
+ (for-each puts (map module-name (module-uses (current-module))))
+ (for-each use args))))
+
+(define (load repl file . opts)
+ "load FILE
+Load a file in the current module.
+
+ -f Load source file (see `compile')"
+ (let* ((file (->string file))
+ (objcode (if (memq #:f opts)
+ (apply load-source-file file opts)
+ (apply load-file file opts))))
+ (vm-load (repl-vm repl) objcode)))
+
+(define (binding repl . opts)
+ "binding
+List current bindings."
+ (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
+ (current-module)))
+
+\f
+;;;
+;;; Language commands
+;;;
+
+(define (language repl name)
+ "language LANGUAGE
+Change languages."
+ (set! (repl-language repl) (lookup-language name))
+ (repl-welcome repl))
+
+\f
+;;;
+;;; Compile commands
+;;;
+
+(define (compile repl form . opts)
+ "compile FORM
+Generate compiled code.
+
+ -e Stop after expanding syntax/macro
+ -t Stop after translating into GHIL
+ -c Stop after generating GLIL
+
+ -O Enable optimization
+ -D Add debug information"
+ (let ((x (apply repl-compile repl (repl-parse repl form) opts)))
+ (cond ((objcode? x) (disassemble-objcode x))
+ (else (repl-print repl x)))))
+
+(define guile:compile-file compile-file)
+(define (compile-file repl file . opts)
+ "compile-file FILE
+Compile a file."
+ (guile:compile-file (->string file) #:opts opts))
+
+(define (guile:disassemble x)
+ ((@ (language assembly disassemble) disassemble) x))
+
+(define (disassemble repl prog)
+ "disassemble PROGRAM
+Disassemble a program."
+ (guile:disassemble (repl-eval repl (repl-parse repl prog))))
+
+(define (disassemble-file repl file)
+ "disassemble-file FILE
+Disassemble a file."
+ (guile:disassemble (load-objcode (->string file))))
+
+\f
+;;;
+;;; Profile commands
+;;;
+
+(define (time repl form)
+ "time FORM
+Time execution."
+ (let* ((vms-start (vm-stats (repl-vm repl)))
+ (gc-start (gc-run-time))
+ (tms-start (times))
+ (result (repl-eval repl (repl-parse 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 (repl-parse repl form))
+ opts))
+
+\f
+;;;
+;;; Debug commands
+;;;
+
+(define (backtrace repl)
+ "backtrace
+Display backtrace."
+ (vm-backtrace (repl-vm repl)))
+
+(define (debugger repl)
+ "debugger
+Start debugger."
+ (vm-debugger (repl-vm repl)))
+
+(define (trace repl form . opts)
+ "trace FORM
+Trace execution.
+
+ -s Display stack
+ -l Display local variables
+ -e Display external variables
+ -b Bytecode level trace"
+ (apply vm-trace (repl-vm repl)
+ (repl-compile repl (repl-parse repl form))
+ opts))
+
+(define (step repl)
+ "step FORM
+Step execution."
+ (display "Not implemented yet\n"))
+
+\f
+;;;
+;;; System commands
+;;;
+
+(define guile:gc gc)
+(define (gc repl)
+ "gc
+Garbage collection."
+ (guile:gc))
+
+(define (statistics repl)
+ "statistics
+Display statistics."
+ (let ((this-tms (times))
+ (this-vms (vm-stats (repl-vm repl)))
+ (this-gcs (gc-stats))
+ (last-tms (repl-tm-stats repl))
+ (last-vms (repl-vm-stats repl))
+ (last-gcs (repl-gc-stats repl)))
+ ;; GC times
+ (let ((this-times (assq-ref this-gcs 'gc-times))
+ (last-times (assq-ref last-gcs 'gc-times)))
+ (display-diff-stat "GC times:" #t this-times last-times "times")
+ (newline))
+ ;; Memory size
+ (let ((this-cells (assq-ref this-gcs 'cells-allocated))
+ (this-heap (assq-ref this-gcs 'cell-heap-size))
+ (this-bytes (assq-ref this-gcs 'bytes-malloced))
+ (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
+ (display-stat-title "Memory size:" "current" "limit")
+ (display-stat "heap" #f this-cells this-heap "cells")
+ (display-stat "malloc" #f this-bytes this-malloc "bytes")
+ (newline))
+ ;; Cells collected
+ (let ((this-marked (assq-ref this-gcs 'cells-marked))
+ (last-marked (assq-ref last-gcs 'cells-marked))
+ (this-swept (assq-ref this-gcs 'cells-swept))
+ (last-swept (assq-ref last-gcs 'cells-swept)))
+ (display-stat-title "Cells collected:" "diff" "total")
+ (display-diff-stat "marked" #f this-marked last-marked "cells")
+ (display-diff-stat "swept" #f this-swept last-swept "cells")
+ (newline))
+ ;; GC time taken
+ (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken))
+ (last-mark (assq-ref last-gcs 'gc-mark-time-taken))
+ (this-total (assq-ref this-gcs 'gc-time-taken))
+ (last-total (assq-ref last-gcs 'gc-time-taken)))
+ (display-stat-title "GC time taken:" "diff" "total")
+ (display-time-stat "mark" this-mark last-mark)
+ (display-time-stat "total" this-total last-total)
+ (newline))
+ ;; Process time spent
+ (let ((this-utime (tms:utime this-tms))
+ (last-utime (tms:utime last-tms))
+ (this-stime (tms:stime this-tms))
+ (last-stime (tms:stime last-tms))
+ (this-cutime (tms:cutime this-tms))
+ (last-cutime (tms:cutime last-tms))
+ (this-cstime (tms:cstime this-tms))
+ (last-cstime (tms:cstime last-tms)))
+ (display-stat-title "Process time spent:" "diff" "total")
+ (display-time-stat "user" this-utime last-utime)
+ (display-time-stat "system" this-stime last-stime)
+ (display-time-stat "child user" this-cutime last-cutime)
+ (display-time-stat "child system" this-cstime last-cstime)
+ (newline))
+ ;; VM statistics
+ (let ((this-time (vms:time this-vms))
+ (last-time (vms:time last-vms))
+ (this-clock (vms:clock this-vms))
+ (last-clock (vms:clock last-vms)))
+ (display-stat-title "VM statistics:" "diff" "total")
+ (display-time-stat "time spent" this-time last-time)
+ (display-diff-stat "bogoclock" #f this-clock last-clock "clock")
+ (display-mips-stat "bogomips" this-time this-clock last-time last-clock)
+ (newline))
+ ;; Save statistics
+ ;; Save statistics
+ (set! (repl-tm-stats repl) this-tms)
+ (set! (repl-vm-stats repl) this-vms)
+ (set! (repl-gc-stats repl) this-gcs)))
+
+(define (display-stat title flag field1 field2 unit)
+ (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
+ (format #t str title field1 field2 unit)))
+
+(define (display-stat-title title field1 field2)
+ (display-stat title #t field1 field2 ""))
+
+(define (display-diff-stat title flag this last unit)
+ (display-stat title flag (- this last) this unit))
+
+(define (display-time-stat title this last)
+ (define (conv num)
+ (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second))))
+ (display-stat title #f (conv (- this last)) (conv this) "s"))
+
+(define (display-mips-stat title this-time this-clock last-time last-clock)
+ (define (mips time clock)
+ (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0))))
+ (display-stat title #f
+ (mips (- this-time last-time) (- this-clock last-clock))
+ (mips this-time this-clock) "mips"))
--- /dev/null
+;;; Repl common routines
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl common)
+ #:use-syntax (system base syntax)
+ #:use-module (system base compile)
+ #:use-module (system base language)
+ #:use-module (system vm vm)
+ #:export (<repl> make-repl repl-vm repl-language repl-options
+ repl-tm-stats repl-gc-stats repl-vm-stats
+ repl-welcome repl-prompt repl-read repl-compile repl-eval
+ repl-parse repl-print repl-option-ref repl-option-set!
+ puts ->string user-error))
+
+\f
+;;;
+;;; Repl type
+;;;
+
+(define-record/keywords <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)
+ (let ((to (lookup-language (cond ((memq #:e opts) 'scheme)
+ ((memq #:t opts) 'ghil)
+ ((memq #:c opts) 'glil)
+ (else 'objcode)))))
+ (compile form #:from (repl-language repl) #:to to #:opts opts)))
+
+(define (repl-parse repl form)
+ (let ((parser (language-parser (repl-language repl))))
+ (if parser (parser form) form)))
+
+(define (repl-eval repl form)
+ (let ((eval (language-evaluator (repl-language repl))))
+ (if (and eval
+ (or (null? (language-compilers (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
+ ;; The result of an evaluation is representable in scheme, and
+ ;; should be printed with the generic printer, `write'. The
+ ;; language-printer is something else: it prints expressions of
+ ;; a given language, not the result of evaluation.
+ (write val)
+ (newline))))
+
+(define (repl-option-ref repl key)
+ (assq-ref (repl-options repl) key))
+
+(define (repl-option-set! repl key val)
+ (set! (repl-options repl) (assq-set! (repl-options repl) key val)))
+
+\f
+;;;
+;;; Utilities
+;;;
+
+(define (puts x) (display x) (newline))
+
+(define (->string x)
+ (object->string x display))
+
+(define (user-error msg . args)
+ (throw 'user-error #f msg args #f))
--- /dev/null
+;;; Describe objects
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl describe)
+ #:use-module (oop goops)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 and-let-star)
+ #:export (describe))
+
+(define-method (describe (symbol <symbol>))
+ (format #t "`~s' is " symbol)
+ (if (not (defined? symbol))
+ (display "not defined in the current module.\n")
+ (describe-object (module-ref (current-module) symbol))))
+
+\f
+;;;
+;;; Display functions
+;;;
+
+(define (safe-class-name class)
+ (if (slot-bound? class 'name)
+ (class-name class)
+ class))
+
+(define-method (display-class class . args)
+ (let* ((name (safe-class-name class))
+ (desc (if (pair? args) (car args) name)))
+ (if (eq? *describe-format* 'tag)
+ (format #t "@class{~a}{~a}" name desc)
+ (format #t "~a" desc))))
+
+(define (display-list title list)
+ (if title (begin (display title) (display ":\n\n")))
+ (if (null? list)
+ (display "(not defined)\n")
+ (for-each display-summary list)))
+
+(define (display-slot-list title instance list)
+ (if title (begin (display title) (display ":\n\n")))
+ (if (null? list)
+ (display "(not defined)\n")
+ (for-each (lambda (slot)
+ (let ((name (slot-definition-name slot)))
+ (display "Slot: ")
+ (display name)
+ (if (and instance (slot-bound? instance name))
+ (begin
+ (display " = ")
+ (display (slot-ref instance name))))
+ (newline)))
+ list)))
+
+(define (display-file location)
+ (display "Defined in ")
+ (if (eq? *describe-format* 'tag)
+ (format #t "@location{~a}.\n" location)
+ (format #t "`~a'.\n" location)))
+
+(define (format-documentation doc)
+ (with-current-buffer (make-buffer #:text doc)
+ (lambda ()
+ (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?")))
+ (do-while (match (re-search-forward regexp))
+ (let ((key (string->symbol (match:substring match 1)))
+ (value (match:substring match 3)))
+ (case key
+ ((deffnx)
+ (delete-region! (match:start match)
+ (begin (forward-line) (point))))
+ ((var)
+ (replace-match! match 0 (string-upcase value)))
+ ((code)
+ (replace-match! match 0 (string-append "`" value "'")))))))
+ (display (string (current-buffer)))
+ (newline))))
+
+\f
+;;;
+;;; Top
+;;;
+
+(define description-table
+ (list
+ (cons <boolean> "a boolean")
+ (cons <null> "an empty list")
+ (cons <integer> "an integer")
+ (cons <real> "a real number")
+ (cons <complex> "a complex number")
+ (cons <char> "a character")
+ (cons <symbol> "a symbol")
+ (cons <keyword> "a keyword")
+ (cons <promise> "a promise")
+ (cons <hook> "a hook")
+ (cons <fluid> "a fluid")
+ (cons <stack> "a stack")
+ (cons <variable> "a variable")
+ (cons <regexp> "a regexp object")
+ (cons <module> "a module object")
+ (cons <unknown> "an unknown object")))
+
+(define-generic describe-object)
+(export describe-object)
+
+(define-method (describe-object (obj <top>))
+ (display-type obj)
+ (display-location obj)
+ (newline)
+ (display-value obj)
+ (newline)
+ (display-documentation obj))
+
+(define-generic display-object)
+(define-generic display-summary)
+(define-generic display-type)
+(define-generic display-value)
+(define-generic display-location)
+(define-generic display-description)
+(define-generic display-documentation)
+(export display-object display-summary display-type display-value
+ display-location display-description display-documentation)
+
+(define-method (display-object (obj <top>))
+ (write obj))
+
+(define-method (display-summary (obj <top>))
+ (display "Value: ")
+ (display-object obj)
+ (newline))
+
+(define-method (display-type (obj <top>))
+ (cond
+ ((eof-object? obj) (display "the end-of-file object"))
+ ((unspecified? obj) (display "unspecified"))
+ (else (let ((class (class-of obj)))
+ (display-class class (or (assq-ref description-table class)
+ (safe-class-name class))))))
+ (display ".\n"))
+
+(define-method (display-value (obj <top>))
+ (if (not (unspecified? obj))
+ (begin (display-object obj) (newline))))
+
+(define-method (display-location (obj <top>))
+ *unspecified*)
+
+(define-method (display-description (obj <top>))
+ (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
+ (index (string-index doc #\newline)))
+ (display (make-shared-substring doc 0 (1+ index)))))
+
+(define-method (display-documentation (obj <top>))
+ (display "Not documented.\n"))
+
+\f
+;;;
+;;; Pairs
+;;;
+
+(define-method (display-type (obj <pair>))
+ (cond
+ ((list? obj) (display-class <list> "a list"))
+ ((pair? (cdr obj)) (display "an improper list"))
+ (else (display-class <pair> "a pair")))
+ (display ".\n"))
+
+\f
+;;;
+;;; Strings
+;;;
+
+(define-method (display-type (obj <string>))
+ (if (read-only-string? 'obj)
+ (display "a read-only string")
+ (display-class <string> "a string"))
+ (display ".\n"))
+
+\f
+;;;
+;;; Procedures
+;;;
+
+(define-method (display-object (obj <procedure>))
+ (cond
+ ((closure? obj)
+ ;; Construct output from the source.
+ (display "(")
+ (display (procedure-name obj))
+ (let ((args (cadr (procedure-source obj))))
+ (cond ((null? args) (display ")"))
+ ((pair? args)
+ (let ((str (with-output-to-string (lambda () (display args)))))
+ (format #t " ~a" (string-upcase! (substring str 1)))))
+ (else
+ (format #t " . ~a)" (string-upcase! (symbol->string args)))))))
+ (else
+ ;; Primitive procedure. Let's lookup the dictionary.
+ (and-let* ((entry (lookup-procedure obj)))
+ (let ((name (entry-property entry 'name))
+ (print-arg (lambda (arg)
+ (display " ")
+ (display (string-upcase (symbol->string arg))))))
+ (display "(")
+ (display name)
+ (and-let* ((args (entry-property entry 'args)))
+ (for-each print-arg args))
+ (and-let* ((opts (entry-property entry 'opts)))
+ (display " &optional")
+ (for-each print-arg opts))
+ (and-let* ((rest (entry-property entry 'rest)))
+ (display " &rest")
+ (print-arg rest))
+ (display ")"))))))
+
+(define-method (display-summary (obj <procedure>))
+ (display "Procedure: ")
+ (display-object obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <procedure>))
+ (cond
+ ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
+ ((closure? obj) (display-class <procedure> "a procedure"))
+ ((procedure-with-setter? obj)
+ (display-class <procedure-with-setter> "a procedure with setter"))
+ ((not (struct? obj)) (display "a primitive procedure"))
+ (else (display-class <procedure> "a procedure")))
+ (display ".\n"))
+
+(define-method (display-location (obj <procedure>))
+ (and-let* ((entry (lookup-procedure obj)))
+ (display-file (entry-file entry))))
+
+(define-method (display-documentation (obj <procedure>))
+ (cond ((cond ((closure? obj) (procedure-documentation obj))
+ ((lookup-procedure obj) => entry-text)
+ (else #f))
+ => format-documentation)
+ (else (next-method))))
+
+\f
+;;;
+;;; Classes
+;;;
+
+(define-method (describe-object (obj <class>))
+ (display-type obj)
+ (display-location obj)
+ (newline)
+ (display-documentation obj)
+ (newline)
+ (display-value obj))
+
+(define-method (display-summary (obj <class>))
+ (display "Class: ")
+ (display-class obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <class>))
+ (display-class <class> "a class")
+ (if (not (eq? (class-of obj) <class>))
+ (begin (display " of ") (display-class (class-of obj))))
+ (display ".\n"))
+
+(define-method (display-value (obj <class>))
+ (display-list "Class precedence list" (class-precedence-list obj))
+ (newline)
+ (display-list "Direct superclasses" (class-direct-supers obj))
+ (newline)
+ (display-list "Direct subclasses" (class-direct-subclasses obj))
+ (newline)
+ (display-slot-list "Direct slots" #f (class-direct-slots obj))
+ (newline)
+ (display-list "Direct methods" (class-direct-methods obj)))
+
+\f
+;;;
+;;; Instances
+;;;
+
+(define-method (display-type (obj <object>))
+ (display-class <object> "an instance")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method (display-value (obj <object>))
+ (display-slot-list #f obj (class-slots (class-of obj))))
+
+\f
+;;;
+;;; Generic functions
+;;;
+
+(define-method (display-type (obj <generic>))
+ (display-class <generic> "a generic function")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method (display-value (obj <generic>))
+ (display-list #f (generic-function-methods obj)))
+
+\f
+;;;
+;;; Methods
+;;;
+
+(define-method (display-object (obj <method>))
+ (display "(")
+ (let ((gf (method-generic-function obj)))
+ (display (if gf (generic-function-name gf) "#<anonymous>")))
+ (let loop ((args (method-specializers obj)))
+ (cond
+ ((null? args))
+ ((pair? args)
+ (display " ")
+ (display-class (car args))
+ (loop (cdr args)))
+ (else (display " . ") (display-class args))))
+ (display ")"))
+
+(define-method (display-summary (obj <method>))
+ (display "Method: ")
+ (display-object obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <method>))
+ (display-class <method> "a method")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method (display-documentation (obj <method>))
+ (let ((doc (procedure-documentation (method-procedure obj))))
+ (if doc (format-documentation doc) (next-method))))
--- /dev/null
+;;; Read-Eval-Print Loop
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl repl)
+ #:use-syntax (system base syntax)
+ #:use-module (system base pmatch)
+ #:use-module (system base compile)
+ #:use-module (system base language)
+ #:use-module (system repl common)
+ #:use-module (system repl command)
+ #:use-module (system vm vm)
+ #:use-module (system vm debug)
+ #:use-module (ice-9 rdelim)
+ #:export (start-repl call-with-backtrace))
+
+(define meta-command-token (cons 'meta 'command))
+
+(define (meta-reader read)
+ (lambda read-args
+ (with-input-from-port
+ (if (pair? read-args) (car read-args) (current-input-port))
+ (lambda ()
+ (let ((ch (next-char #t)))
+ (cond ((eof-object? ch)
+ ;; apparently sometimes even if this is eof, read will
+ ;; wait on somethingorother. strange.
+ ch)
+ ((eqv? ch #\,)
+ (read-char)
+ meta-command-token)
+ (else (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-catch-handler . args)
+ (pmatch args
+ ((quit . _)
+ (apply throw args))
+ ((,key ,subr ,msg ,args . ,rest)
+ (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
+ (format (current-error-port) "\nERROR: uncaught throw to `~a', args: ~a\n"
+ (car args) (cdr args)))))
+
+(define (call-with-backtrace thunk)
+ (catch #t
+ (lambda () (%start-stack #t thunk))
+ default-catch-handler
+ pre-unwind-handler-dispatch))
+
+(define-macro (with-backtrace form)
+ `(call-with-backtrace (lambda () ,form)))
+
+(define (start-repl lang)
+ (let ((repl (make-repl lang))
+ (status #f))
+ (repl-welcome repl)
+ (let prompt-loop ()
+ (let ((exp (with-backtrace (prompting-meta-read repl))))
+ (cond
+ ((eqv? exp (if #f #f))) ; read error, pass
+ ((eq? exp meta-command-token)
+ (with-backtrace (meta-command repl (read-line))))
+ ((eof-object? exp)
+ (newline)
+ (set! status '()))
+ (else
+ (with-backtrace
+ (catch 'quit
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (run-hook before-eval-hook exp)
+ (start-stack #t
+ (repl-eval repl (repl-parse 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))
--- /dev/null
+;;; Guile VM debugging facilities
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm debug)
+ #:use-syntax (system base syntax)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (ice-9 format)
+ #:export (vm-debugger vm-backtrace))
+
+\f
+;;;
+;;; Debugger
+;;;
+
+(define-record/keywords <debugger> vm chain index)
+
+(define (vm-debugger vm)
+ (let ((chain (vm-last-frame-chain vm)))
+ (if (null? chain)
+ (display "Nothing to debug\n")
+ (debugger-repl (make-debugger
+ #:vm vm #:chain chain #:index (length chain))))))
+
+(define (debugger-repl db)
+ (let loop ()
+ (display "debug> ")
+ (let ((cmd (read)))
+ (case cmd
+ ((bt) (vm-backtrace (debugger-vm db)))
+ ((stack)
+ (write (vm-fetch-stack (debugger-vm db)))
+ (newline))
+ (else
+ (format #t "Unknown command: ~A" cmd))))))
+
+\f
+;;;
+;;; Backtrace
+;;;
+
+(define (vm-backtrace vm)
+ (print-frame-chain-as-backtrace
+ (reverse (vm-last-frame-chain vm))))
--- /dev/null
+;;; Guile VM 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 (vm-frame?
+ vm-frame-program
+ vm-frame-local-ref vm-frame-local-set!
+ vm-frame-return-address vm-frame-mv-return-address
+ vm-frame-dynamic-link vm-frame-external-link
+ vm-frame-stack
+
+
+ vm-frame-number vm-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 vm-frame-number (make-object-property))
+(define vm-frame-address (make-object-property))
+
+;; FIXME: the header.
+(define (bootstrap-frame? frame)
+ (let ((code (objcode->bytecode (program-objcode (frame-program frame)))))
+ (and (= (uniform-vector-ref code (1- (uniform-vector-length code)))
+ (instruction->opcode 'halt)))))
+
+(define (make-frame-chain frame addr)
+ (define (make-rest)
+ (make-frame-chain (frame-dynamic-link frame)
+ (frame-return-address frame)))
+ (cond
+ ((or (eq? frame #t) (eq? frame #f))
+ ;; handle #f or #t dynamic links
+ '())
+ ((bootstrap-frame? frame)
+ (make-rest))
+ (else
+ (let ((chain (make-rest)))
+ (set! (frame-number frame) (length chain))
+ (set! (frame-address frame)
+ (- addr (program-base (frame-program frame))))
+ (cons frame chain)))))
+
+\f
+;;;
+;;; Pretty printing
+;;;
+
+(define (frame-line-number frame)
+ (let ((addr (frame-address frame)))
+ (cond ((assv addr (program-sources (frame-program frame)))
+ => source:line)
+ (else (format #f "@~a" addr)))))
+
+(define (frame-file frame prev)
+ (let ((sources (program-sources (frame-program frame))))
+ (if (null? sources)
+ prev
+ (or (source:file (car sources))
+ "current input"))))
+
+(define (print-frame frame)
+ (format #t "~4@a: ~a ~s\n" (frame-line-number frame) (frame-number frame)
+ (frame-call-representation frame)))
+
+
+(define (frame-call-representation frame)
+ (define (abbrev x)
+ (cond ((list? x)
+ (if (> (length x) 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))))))
+
+\f
+;;;
+;;; Frames
+;;;
+
+(define (frame-arguments frame)
+ (let* ((prog (frame-program frame))
+ (arity (program-arity prog)))
+ (do ((n (+ (arity:nargs arity) -1) (1- n))
+ (l '() (cons (frame-local-ref frame n) l)))
+ ((< n 0) l))))
+
+(define (frame-local-variables frame)
+ (let* ((prog (frame-program frame))
+ (arity (program-arity prog)))
+ (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
+ (l '() (cons (frame-local-ref frame n) l)))
+ ((< n 0) l))))
+
+(define (frame-external-variables frame)
+ (frame-external-link frame))
+
+(define (frame-external-ref frame index)
+ (list-ref (frame-external-link frame) index))
+
+(define (frame-external-set! frame index val)
+ (list-set! (frame-external-link frame) index val))
+
+(define (frame-binding-ref frame binding)
+ (if (binding:extp binding)
+ (frame-external-ref frame (binding:index binding))
+ (frame-local-ref frame (binding:index binding))))
+
+(define (frame-binding-set! frame binding val)
+ (if (binding:extp binding)
+ (frame-external-set! frame (binding:index binding) val)
+ (frame-local-set! frame (binding:index binding) val)))
+
+;; FIXME handle #f program-bindings return
+(define (frame-bindings frame addr)
+ (filter (lambda (b) (and (>= addr (binding:start b))
+ (<= addr (binding:end b))))
+ (program-bindings (frame-program frame))))
+
+(define (frame-lookup-binding frame addr sym)
+ (assq sym (reverse (frame-bindings frame addr))))
+
+(define (frame-object-binding frame addr obj)
+ (do ((bs (frame-bindings frame addr) (cdr bs)))
+ ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
+ (and (pair? bs) (car bs)))))
+
+(define (frame-environment frame addr)
+ (map (lambda (binding)
+ (cons (binding:name binding) (frame-binding-ref frame binding)))
+ (frame-bindings frame addr)))
+
+(define (frame-variable-exists? frame addr sym)
+ (if (frame-lookup-binding frame addr sym) #t #f))
+
+(define (frame-variable-ref frame addr sym)
+ (cond ((frame-lookup-binding frame addr sym) =>
+ (lambda (binding) (frame-binding-ref frame binding)))
+ (else (error "Unknown variable:" sym))))
+
+(define (frame-variable-set! frame addr sym val)
+ (cond ((frame-lookup-binding frame addr sym) =>
+ (lambda (binding) (frame-binding-set! frame binding val)))
+ (else (error "Unknown variable:" sym))))
+
+(define (frame-object-name frame addr obj)
+ (cond ((frame-object-binding frame addr obj) => binding:name)
+ (else #f)))
--- /dev/null
+;;; Guile VM instructions
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm instruction)
+ #:export (instruction-list
+ instruction? instruction-length
+ instruction-pops instruction-pushes
+ instruction->opcode opcode->instruction))
+
+(dynamic-call "scm_init_instructions" (dynamic-link "libguile"))
--- /dev/null
+;;; Guile VM object code
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm objcode)
+ #:export (objcode? objcode-meta
+ bytecode->objcode objcode->bytecode
+ load-objcode write-objcode
+ word-size byte-order))
+
+(dynamic-call "scm_init_objcodes" (dynamic-link "libguile"))
--- /dev/null
+;;; Guile VM profiler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm profile)
+ #:use-module (system vm vm)
+ #:use-module (ice-9 format)
+ #:export (vm-profile))
+
+(define (vm-profile vm objcode . opts)
+ (let ((flag (vm-option vm 'debug)))
+ (dynamic-wind
+ (lambda ()
+ (set-vm-option! vm 'debug #t)
+ (set-vm-option! vm 'profile-data '())
+ (add-hook! (vm-next-hook vm) profile-next)
+ (add-hook! (vm-enter-hook vm) profile-enter)
+ (add-hook! (vm-exit-hook vm) profile-exit))
+ (lambda ()
+ (vm-load vm objcode)
+ (print-result vm))
+ (lambda ()
+ (set-vm-option! vm 'debug flag)
+ (remove-hook! (vm-next-hook vm) profile-next)
+ (remove-hook! (vm-enter-hook vm) profile-enter)
+ (remove-hook! (vm-exit-hook vm) profile-exit)))))
+
+(define (profile-next vm)
+ (set-vm-option! vm 'profile-data
+ (cons (vm-fetch-code vm) (vm-option vm 'profile-data))))
+
+(define (profile-enter vm)
+ #f)
+
+(define (profile-exit vm)
+ #f)
+
+(define (print-result vm . opts)
+ (do ((data (vm-option vm 'profile-data) (cdr data))
+ (summary '() (let ((inst (caar data)))
+ (assq-set! summary inst
+ (1+ (or (assq-ref summary inst) 0))))))
+ ((null? data)
+ (display "Count Instruction\n")
+ (display "----- -----------\n")
+ (for-each (lambda (entry)
+ (format #t "~5@A ~A\n" (cdr entry) (car entry)))
+ (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2))))))))
--- /dev/null
+;;; Guile VM program functions
+
+;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm program)
+ #:export (make-program
+
+ arity:nargs arity:nrest arity:nlocs arity:nexts
+
+ make-binding binding:name binding:extp binding:index
+ binding:start binding:end
+
+ source:addr source:line source:column source:file
+ program-bindings program-sources program-source
+ program-properties program-property program-documentation
+ program-name program-arguments
+
+ program-arity program-external-set! program-meta
+ program-objcode 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 start end)
+ (list name extp index start end))
+(define (binding:name b) (list-ref b 0))
+(define (binding:extp b) (list-ref b 1))
+(define (binding:index b) (list-ref b 2))
+(define (binding:start b) (list-ref b 3))
+(define (binding:end b) (list-ref b 4))
+
+(define (source:addr source)
+ (car source))
+(define (source:file source)
+ (cadr source))
+(define (source:line source)
+ (caddr source))
+(define (source:column source)
+ (cdddr source))
+
+(define (program-property prog prop)
+ (assq-ref (program-properties proc) prop))
+
+(define (program-documentation prog)
+ (assq-ref (program-properties prog) 'documentation))
+
+(define (program-arguments prog)
+ (let ((bindings (program-bindings prog))
+ (nargs (arity:nargs (program-arity prog)))
+ (rest? (not (zero? (arity:nrest (program-arity prog))))))
+ (if bindings
+ (let ((args (map binding:name (list-head bindings nargs))))
+ (if rest?
+ `((required . ,(list-head args (1- (length args))))
+ (rest . ,(car (last-pair args))))
+ `((required . ,args))))
+ #f)))
+
+(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 (not bindings)
+ (if rest? (cons (1- nargs) 1) (list nargs))
+ (let ((args (map binding:name (list-head bindings nargs))))
+ (if rest?
+ (apply cons* args)
+ args)))))
+
+(define (write-program prog port)
+ (format port "#<program ~a ~a>"
+ (or (program-name prog)
+ (and=> (program-source prog 0)
+ (lambda (s)
+ (format #f "~a at ~a:~a:~a"
+ (number->string (object-address prog) 16)
+ (or (source:file s) "<unknown port>")
+ (source:line s) (source:column s))))
+ (number->string (object-address prog) 16))
+ (program-bindings-as-lambda-list prog)))
--- /dev/null
+;;; Guile VM tracer
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm trace)
+ #:use-syntax (system base syntax)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (ice-9 format)
+ #:export (vm-trace vm-trace-on vm-trace-off))
+
+(define (vm-trace vm objcode . opts)
+ (dynamic-wind
+ (lambda () (apply vm-trace-on vm opts))
+ (lambda () (vm-load vm objcode))
+ (lambda () (apply vm-trace-off vm opts))))
+
+(define (vm-trace-on vm . opts)
+ (set-vm-option! vm 'trace-first #t)
+ (if (memq #:b opts) (add-hook! (vm-next-hook vm) trace-next))
+ (set-vm-option! vm 'trace-options opts)
+ (add-hook! (vm-apply-hook vm) trace-apply)
+ (add-hook! (vm-return-hook vm) trace-return))
+
+(define (vm-trace-off vm . opts)
+ (if (memq #:b opts) (remove-hook! (vm-next-hook vm) trace-next))
+ (remove-hook! (vm-apply-hook vm) trace-apply)
+ (remove-hook! (vm-return-hook vm) trace-return))
+
+(define (trace-next vm)
+ (define (puts x) (display #\tab) (write x))
+ (define (truncate! x n)
+ (if (> (length x) n)
+ (list-cdr-set! x (1- n) '(...))) x)
+ ;; main
+ (format #t "0x~8X ~16S" (vm:ip vm) (vm-fetch-code vm))
+ (do ((opts (vm-option vm 'trace-options) (cdr opts)))
+ ((null? opts) (newline))
+ (case (car opts)
+ ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
+ ((:l) (puts (vm-fetch-locals vm)))
+ ((:e) (puts (vm-fetch-externals vm))))))
+
+(define (trace-apply vm)
+ (if (vm-option vm 'trace-first)
+ (set-vm-option! vm 'trace-first #f)
+ (let ((chain (vm-current-frame-chain vm)))
+ (print-indent chain)
+ (print-frame-call (car chain))
+ (newline))))
+
+(define (trace-return vm)
+ (let ((chain (vm-current-frame-chain vm)))
+ (print-indent chain)
+ (write (vm-return-value vm))
+ (newline)))
+
+(define (print-indent chain)
+ (cond ((pair? (cdr chain))
+ (display "| ")
+ (print-indent (cdr chain)))))
--- /dev/null
+;;; Guile VM core
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
+ #:export (vm? the-vm make-vm vm-version
+ vm:ip vm:sp vm:fp vm:last-ip
+
+ vm-load vm-option set-vm-option! vm-version vm-stats
+ vms:time vms:clock
+
+ vm-trace-frame
+ 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 (vms:time stat) (vector-ref stat 0))
+(define (vms:clock stat) (vector-ref stat 1))
+
+(define (vm-load vm objcode)
+ (vm (make-program objcode)))
+++ /dev/null
-;;;; Copyright (C) 1999, 2000, 2005, 2006 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
-;;;;
-\f
-
-(define-module (oop goops accessors)
- :use-module (oop goops)
- :re-export (standard-define-class)
- :export (define-class-with-accessors
- define-class-with-accessors-keywords))
-
-(define define-class-with-accessors
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp))
- (supers (caddr exp))
- (slots (cdddr exp))
- (eat? #f))
- `(standard-define-class ,name ,supers
- ,@(map-in-order
- (lambda (slot)
- (cond (eat?
- (set! eat? #f)
- slot)
- ((keyword? slot)
- (set! eat? #t)
- slot)
- ((pair? slot)
- (if (get-keyword #:accessor (cdr slot) #f)
- slot
- (let ((name (car slot)))
- `(,name #:accessor ,name ,@(cdr slot)))))
- (else
- `(,slot #:accessor ,slot))))
- slots))))))
-
-(define define-class-with-accessors-keywords
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp))
- (supers (caddr exp))
- (slots (cdddr exp))
- (eat? #f))
- `(standard-define-class ,name ,supers
- ,@(map-in-order
- (lambda (slot)
- (cond (eat?
- (set! eat? #f)
- slot)
- ((keyword? slot)
- (set! eat? #t)
- slot)
- ((pair? slot)
- (let ((slot
- (if (get-keyword #:accessor (cdr slot) #f)
- slot
- (let ((name (car slot)))
- `(,name #:accessor ,name ,@(cdr slot))))))
- (if (get-keyword #:init-keyword (cdr slot) #f)
- slot
- (let* ((name (car slot))
- (keyword (symbol->keyword name)))
- `(,name #:init-keyword ,keyword ,@(cdr slot))))))
- (else
- `(,slot #:accessor ,slot
- #:init-keyword ,(symbol->keyword slot)))))
- slots))))))
+++ /dev/null
-;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
-\f
-
-(define-module (oop goops compile)
- :use-module (oop goops)
- :use-module (oop goops util)
- :export (compute-cmethod compute-entry-with-cmethod
- compile-method cmethod-code cmethod-environment)
- :no-backtrace
- )
-
-(define source-formals cadr)
-(define source-body cddr)
-
-(define cmethod-code cdr)
-(define cmethod-environment car)
-
-
-;;;
-;;; Method entries
-;;;
-
-(define code-table-lookup
- (letrec ((check-entry (lambda (entry types)
- (if (null? types)
- (and (not (struct? (car entry)))
- entry)
- (and (eq? (car entry) (car types))
- (check-entry (cdr entry) (cdr types)))))))
- (lambda (code-table types)
- (cond ((null? code-table) #f)
- ((check-entry (car code-table) types)
- => (lambda (cmethod)
- (cons (car code-table) cmethod)))
- (else (code-table-lookup (cdr code-table) types))))))
-
-(define (compute-entry-with-cmethod methods types)
- (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
- (let* ((method (car methods))
- (place-holder (list #f))
- (entry (append types place-holder)))
- ;; In order to handle recursion nicely, put the entry
- ;; into the code-table before compiling the method
- (slot-set! (car methods) 'code-table
- (cons entry (slot-ref (car methods) 'code-table)))
- (let ((cmethod (compile-method methods types)))
- (set-car! place-holder (car cmethod))
- (set-cdr! place-holder (cdr cmethod)))
- (cons entry place-holder))))
-
-(define (compute-cmethod methods types)
- (cdr (compute-entry-with-cmethod methods types)))
-
-;;;
-;;; Next methods
-;;;
-
-;;; Temporary solution---return #f if x doesn't refer to `next-method'.
-(define (next-method? x)
- (and (pair? x)
- (or (eq? (car x) 'next-method)
- (next-method? (car x))
- (next-method? (cdr x)))))
-
-(define (make-final-make-next-method method)
- (lambda default-args
- (lambda args
- (@apply method (if (null? args) default-args args)))))
-
-(define (make-final-make-no-next-method gf)
- (lambda default-args
- (lambda args
- (no-next-method gf (if (null? args) default-args args)))))
-
-(define (make-make-next-method vcell gf methods types)
- (lambda default-args
- (lambda args
- (if (null? methods)
- (begin
- (set-cdr! vcell (make-final-make-no-next-method gf))
- (no-next-method gf (if (null? args) default-args args)))
- (let* ((cmethod (compute-cmethod methods types))
- (method (local-eval (cons 'lambda (cmethod-code cmethod))
- (cmethod-environment cmethod))))
- (set-cdr! vcell (make-final-make-next-method method))
- (@apply method (if (null? args) default-args args)))))))
-
-;;;
-;;; Method compilation
-;;;
-
-;;; NOTE: This section is far from finished. It will finally be
-;;; implemented on C level.
-
-(define %tag-body
- (nested-ref the-root-module '(app modules oop goops %tag-body)))
-
-(define (compile-method methods types)
- (let* ((proc (method-procedure (car methods)))
- ;; XXX - procedure-source can not be guaranteed to be
- ;; reliable or efficient
- (src (procedure-source proc))
- (formals (source-formals src))
- (body (source-body src)))
- (if (next-method? body)
- (let ((vcell (cons 'goops:make-next-method #f)))
- (set-cdr! vcell
- (make-make-next-method
- vcell
- (method-generic-function (car methods))
- (cdr methods) types))
- ;;*fixme*
- `(,(cons vcell (procedure-environment proc))
- ,formals
- ;;*fixme* Only do this on source where next-method can't be inlined
- (let ((next-method ,(if (list? formals)
- `(goops:make-next-method ,@formals)
- `(apply goops:make-next-method
- ,@(improper->proper formals)))))
- ,@body)))
- (cons (procedure-environment proc)
- (cons formals
- (%tag-body body)))
- )))
+++ /dev/null
-;;; installed-scm-file
-
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
-\f
-
-(define-module (oop goops old-define-method)
- :use-module (oop goops)
- :export (define-method)
- :no-backtrace
- )
-
-(define define-method
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp)))
- (if (and (pair? name)
- (eq? (car name) 'setter)
- (pair? (cdr name))
- (symbol? (cadr name))
- (null? (cddr name)))
- (let ((name (cadr name)))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- ;; *fixme* Temporary hack for the current module system
- (if (not ,name)
- (define-accessor ,name))
- (add-method! (setter ,name) (method ,@(cddr exp)))))
- (else
- `(begin
- (define-accessor ,name)
- (add-method! (setter ,name) (method ,@(cddr exp)))))))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- ;; *fixme* Temporary hack for the current module system
- (if (not ,name)
- (define-generic ,name))
- (add-method! ,name (method ,@(cddr exp)))))
- (else
- `(begin
- (define-generic ,name)
- (add-method! ,name (method ,@(cddr exp)))))))))))
# Example: ../../pre-inst-guile-env ./guile-test-foo
# config
-subdirs_with_ltlibs="srfi guile-readline" # maintain me
+subdirs_with_ltlibs="srfi guile-readline libguile" # maintain me
# env (set by configure)
top_srcdir="@top_srcdir_absolute@"
if [ x"$GUILE_LOAD_PATH" = x ]
then
- GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}"
+ if test "${top_srcdir}" != "${top_builddir}"; then
+ GUILE_LOAD_PATH="${top_builddir}/guile-readline:${top_srcdir}/guile-readline:${top_builddir}:${top_srcdir}:${top_builddir}/module:${top_srcdir}/module"
+ else
+ GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}:${top_builddir}/module:${top_srcdir}/module"
+ fi
else
- for d in "${top_srcdir}" "${top_srcdir}/guile-readline"
+ for d in "${top_srcdir}" "${top_srcdir}/guile-readline" \
+ "${top_srcdir}/module" "${top_builddir}/module"
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
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=""
# to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
# Floor, Boston, MA 02110-1301 USA
-# NOTE: at some point we might consider invoking this under
-# pre-inst-guile-env. If this will work, then most of the code below
-# can be removed.
-
-# NOTE: If you update this file, please update pre-inst-guile-env.in
-# as well, if appropriate.
-
# Commentary:
# Usage: pre-inst-guile [ARGS]
# Code:
-# config
-subdirs_with_ltlibs="srfi guile-readline libguile" # maintain me
-
# env (set by configure)
-top_srcdir="@top_srcdir_absolute@"
top_builddir="@top_builddir_absolute@"
-[ x"$top_srcdir" = x -o ! -d "$top_srcdir" -o \
- x"$top_builddir" = x -o ! -d "$top_builddir" ] && {
- echo $0: bad environment
- echo top_srcdir=$top_srcdir
- echo top_builddir=$top_builddir
- exit 1
-}
-
-# handle GUILE_LOAD_PATH (no clobber)
-if [ x"$GUILE_LOAD_PATH" = x ]
-then
- GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}"
-else
- for d in "${top_srcdir}" "${top_srcdir}/guile-readline"
- do
- # This hair prevents double inclusion.
- # The ":" prevents prefix aliasing.
- case x"$GUILE_LOAD_PATH" in
- x*${d}:*) ;;
- *) GUILE_LOAD_PATH="${d}:$GUILE_LOAD_PATH" ;;
- esac
- done
-fi
-export GUILE_LOAD_PATH
-
-# handle LTDL_LIBRARY_PATH (no clobber)
-ltdl_prefix=""
-dyld_prefix=""
-for dir in $subdirs_with_ltlibs ; do
- ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}"
- dyld_prefix="${top_builddir}/${dir}/.libs:${dyld_prefix}"
-done
-LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH"
-export LTDL_LIBRARY_PATH
-DYLD_LIBRARY_PATH="${dyld_prefix}${top_builddir}/libguile/.libs:$DYLD_LIBRARY_PATH"
-export DYLD_LIBRARY_PATH
-
# set GUILE (clobber)
GUILE=${top_builddir}/libguile/guile
export GUILE
# do it
-exec $GUILE "$@"
+exec ${top_builddir}/pre-inst-guile-env $GUILE "$@"
# never reached
exit 1
scripts_sources = \
PROGRAM \
autofrisk \
+ compile \
+ disassemble \
display-commentary \
doc-snarf \
frisk \
--- /dev/null
+#!/bin/sh
+# -*- scheme -*-
+exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@"
+!#
+;;; Compile --- Command-line Guile Scheme compiler
+
+;; Copyright 2005,2008,2009 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 <ludo@gnu.org>
+;;; 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) #:select (compile-file))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:use-module (srfi srfi-37)
+ #:export (compile))
+
+\f
+(define (fail . messages)
+ (format (current-error-port)
+ (string-concatenate `("error: " ,@messages "~%")))
+ (exit 1))
+
+(define %options
+ ;; Specifications of the command-line options.
+ (list (option '(#\h "help") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'help? #t result)))
+
+ (option '(#\L "load-path") #t #f
+ (lambda (opt name arg result)
+ (let ((load-path (assoc-ref result 'load-path)))
+ (alist-cons 'load-path (cons arg load-path)
+ result))))
+ (option '(#\o "output") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'output-file)
+ (fail "`-o' option cannot be specified more than once")
+ (alist-cons 'output-file arg result))))
+
+ (option '(#\O "optimize") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'optimize? #t result)))
+ (option '(#\e "expand-only") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'expand-only? #t result)))
+ (option '(#\t "translate-only") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'translate-only? #t result)))
+ (option '(#\c "compile-only") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'compile-only? #t result)))))
+
+(define (parse-args args)
+ "Parse argument list @var{args} and return an alist with all the relevant
+options."
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (format (current-error-port) "~A: unrecognized option" opt)
+ (exit 1))
+ (lambda (file result)
+ (let ((input-files (assoc-ref result 'input-files)))
+ (alist-cons 'input-files (cons file input-files)
+ result)))
+
+ ;; default option values
+ '((input-files)
+ (load-path))))
+
+\f
+(define (compile args)
+ (let* ((options (parse-args (cdr args)))
+ (help? (assoc-ref options 'help?))
+ (optimize? (assoc-ref options 'optimize?))
+ (expand-only? (assoc-ref options 'expand-only?))
+ (translate-only? (assoc-ref options 'translate-only?))
+ (compile-only? (assoc-ref options 'compile-only?))
+ (input-files (assoc-ref options 'input-files))
+ (output-file (assoc-ref options 'output-file))
+ (load-path (assoc-ref options 'load-path)))
+ (if (or help? (null? input-files))
+ (begin
+ (format #t "Usage: compile [OPTION] FILE...
+Compile each Guile Scheme source file FILE into a Guile object.
+
+ -h, --help print this help message
+
+ -L, --load-path=DIR add DIR to the front of the module load path
+ -o, --output=OFILE write output to OFILE
+
+ -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)))
+
+ (set! %load-path (append load-path %load-path))
+
+ (let ((compile-opts (append (if optimize? '(#:O) '())
+ (if expand-only? '(#:e) '())
+ (if translate-only? '(#:t) '())
+ (if compile-only? '(#:c) '()))))
+ (if output-file
+ (if (and (not (null? input-files))
+ (null? (cdr input-files)))
+ (compile-file (car input-files) output-file)
+ (fail "`-o' option can only be specified "
+ "when compiling a single file"))
+ (for-each (lambda (file)
+ (apply compile-file file compile-opts))
+ input-files)))))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
--- /dev/null
+#!/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 (language assembly disassemble)
+ #:export (disassemble))
+
+(define (disassemble args)
+ (for-each (lambda (file)
+ (disassemble (load-objcode file)))
+ (cdr args)))
$(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_60_INTERFACE@
-srfidir = $(datadir)/guile/$(GUILE_EFFECTIVE_VERSION)/srfi
-srfi_DATA = srfi-1.scm \
- srfi-2.scm \
- srfi-4.scm \
- srfi-6.scm \
- srfi-8.scm \
- srfi-9.scm \
- srfi-10.scm \
- srfi-11.scm \
- srfi-13.scm \
- srfi-14.scm \
- srfi-16.scm \
- srfi-17.scm \
- srfi-19.scm \
- srfi-26.scm \
- srfi-31.scm \
- srfi-34.scm \
- srfi-35.scm \
- srfi-37.scm \
- srfi-39.scm \
- srfi-60.scm \
- srfi-69.scm \
- srfi-88.scm
-
-EXTRA_DIST = $(srfi_DATA) ChangeLog-2008
-TAGS_FILES = $(srfi_DATA)
+EXTRA_DIST = ChangeLog-2008
GUILE_SNARF = ../libguile/guile-snarf
SCM_TESTS = tests/alist.test \
tests/and-let-star.test \
tests/arbiters.test \
+ tests/asm-to-bytecode.test \
tests/bit-operations.test \
tests/c-api.test \
tests/chars.test \
--- /dev/null
+;;;; test assembly to bytecode compilation -*- scheme -*-
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite tests asm-to-bytecode)
+ #:use-module (test-suite lib)
+ #:use-module (system vm instruction)
+ #:use-module (language assembly compile-bytecode))
+
+(define (munge-bytecode v)
+ (let ((newv (make-u8vector (vector-length v))))
+ (let lp ((i 0))
+ (if (= i (vector-length v))
+ newv
+ (let ((x (vector-ref v i)))
+ (u8vector-set! newv i (if (symbol? x)
+ (instruction->opcode x)
+ x))
+ (lp (1+ i)))))))
+
+(define (comp-test x y)
+ (let* ((y (munge-bytecode y))
+ (len (u8vector-length y))
+ (v (make-u8vector len))
+ (i 0))
+ (define (write-byte b) (u8vector-set! v i b) (set! i (1+ i)))
+ (define (get-addr) i)
+ (run-test `(length ,x) #t
+ (lambda ()
+ (write-bytecode x write-byte get-addr '())
+ (= i len)))
+ (run-test `(compile-equal? ,x ,y) #t
+ (lambda ()
+ (equal? v y)))))
+
+(with-test-prefix "compiler"
+ (with-test-prefix "asm-to-bytecode"
+
+ (comp-test '(make-int8 3)
+ #(make-int8 3))
+
+ (comp-test `(load-integer ,(string (integer->char 0)))
+ #(load-integer 0 0 1 0))
+
+ (comp-test `(load-integer ,(string (integer->char 255)))
+ #(load-integer 0 0 1 255))
+
+ (comp-test `(load-integer ,(string (integer->char 1) (integer->char 0)))
+ #(load-integer 0 0 2 1 0))
+
+ (comp-test '(load-number "3.14")
+ (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.)
+ (char->integer #\1) (char->integer #\4)))
+
+ (comp-test '(load-string "foo")
+ (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o)
+ (char->integer #\o)))
+
+ (comp-test '(load-symbol "foo")
+ (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
+ (char->integer #\o)))
+
+ (comp-test '(load-keyword "qux")
+ (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u)
+ (char->integer #\x)))
+
+ ;; fixme: little-endian test.
+ (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return))
+ (vector 'load-program 3 2 1 0 3 0 0 0 0 0 0 0
+ (instruction->opcode 'make-int8) 3
+ (instruction->opcode 'return)))
+
+ ;; fixme: little-endian test.
+ (comp-test '(load-program 3 2 1 0 () 3
+ (load-program 3 2 1 0 () 3
+ #f
+ (make-int8 3) (return))
+ (make-int8 3) (return))
+ (vector 'load-program 3 2 1 0 3 0 0 0 (+ 3 12) 0 0 0
+ (instruction->opcode 'make-int8) 3
+ (instruction->opcode 'return)
+ 3 2 1 0 3 0 0 0 0 0 0 0
+ (instruction->opcode 'make-int8) 3
+ (instruction->opcode 'return)))))
--- /dev/null
+;;;; compiler.test --- tests for the compiler -*- scheme -*-
+;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite tests compiler)
+ :use-module (test-suite lib)
+ :use-module (test-suite guile-test)
+ :use-module (system vm program))
+
+
+(with-test-prefix "environments"
+
+ (pass-if "compile-time-environment in evaluator"
+ (eq? (primitive-eval '(compile-time-environment)) #f))
+
+ (pass-if "compile-time-environment in compiler"
+ (equal? (compile '(compile-time-environment))
+ (cons (current-module)
+ (cons '() '()))))
+
+ (let ((env (compile
+ '(let ((x 0)) (set! x 1) (compile-time-environment)))))
+ (pass-if "compile-time-environment in compiler, heap-allocated var"
+ (equal? env
+ (cons (current-module)
+ (cons '((x . 0)) '(1)))))
+
+ ;; fixme: compiling with #t or module
+ (pass-if "recompiling with environment"
+ (equal? ((compile '(lambda () x) #:env env))
+ 1))
+
+ (pass-if "recompiling with environment/2"
+ (equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env))
+ 2))
+
+ (pass-if "recompiling with environment/3"
+ (equal? ((compile '(lambda () x) #:env env))
+ 2))
+ )
+
+ (pass-if "compile environment is #f"
+ (equal? ((compile '(lambda () 10)))
+ 10))
+
+ (pass-if "compile environment is a module"
+ (equal? ((compile '(lambda () 10) #:env (current-module)))
+ 10))
+ )
\ No newline at end of file
:use-module (test-suite lib)
:use-module (ice-9 weak-vector))
+(define *old-stack-level* (and=> (memq 'stack (debug-options)) cadr))
+(if *old-stack-level*
+ (debug-set! stack (* 2 *old-stack-level*)))
+
;;;
;;; elisp
;;;
(write (eval-elisp expr))))))
(string=? calc expected))))
+ (define (elisp-pass-if/maybe-error key expr expected)
+ (pass-if (with-output-to-string (lambda () (write expr)))
+ (string=?
+ (catch key
+ (lambda ()
+ (with-output-to-string
+ (lambda () (write (eval-elisp expr)))))
+ (lambda (k . args)
+ (format (current-error-port)
+ "warning: caught ~a: ~a\n" k args)
+ (throw 'unresolved)))
+ expected)))
+
(elisp-pass-if '(and #f) "#f")
(elisp-pass-if '(and #t) "#t")
(elisp-pass-if '(and nil) "#nil")
;; loading the macro definition of lambda in subr.el.
(elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))")
(elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))")
- (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) "(1 2 3 #nil)")
+ (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil)
+ "(1 2 3 #nil)")
+
(elisp-pass-if '(setq x 3) "3")
(elisp-pass-if '(defvar x 4) "x")
(elisp-pass-if 'x "3")
))
+(debug-set! stack *old-stack-level*)
+
;;; elisp.test ends here
;;
(define foo-closure (lambda () "hello"))
(define bar-closure foo-closure)
-(define foo-pws (make-procedure-with-setter car set-car!))
+;; make sure that make-procedure-with-setter returns an anonymous
+;; procedure-with-setter by passing it an anonymous getter.
+(define foo-pws (make-procedure-with-setter
+ (lambda (x) (car x))
+ (lambda (x y) (set-car! x y))))
(define bar-pws foo-pws)
(with-test-prefix "define set procedure-name"
(eq? 'foo-closure (procedure-name bar-closure)))
(pass-if "procedure-with-setter"
- (eq? 'foo-pws (pk (procedure-name bar-pws)))))
+ (eq? 'foo-pws (procedure-name bar-pws))))
(if old-procnames-flag
(debug-enable 'procnames)
;; 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
(and (struct? x)
(eq? (struct-ref x 0) 'hello)
(eq? (struct-ref x 1) 'world)))
- (current-module)))))
+ (current-module)))
+
+ (pass-if "with accessors"
+ (eval '(define-class <qux> ()
+ (x #:accessor x #:init-value 123)
+ (z #:accessor z #:init-value 789))
+ (current-module))
+ (eval '(equal? (x (make <qux>)) 123) (current-module)))))
+
(with-test-prefix "defining generics"
(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)
(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)))))
;; 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
(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))
--- /dev/null
+# The test programs.
+
+# The Libtool executable.
+GUILE_VM = $(top_builddir)/pre-inst-guile
+
+vm_test_files = \
+ t-basic-contructs.scm \
+ t-global-bindings.scm \
+ t-catch.scm \
+ t-call-cc.scm \
+ t-closure.scm \
+ t-closure2.scm \
+ t-closure3.scm \
+ t-closure4.scm \
+ t-do-loop.scm \
+ t-literal-integers.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)
--- /dev/null
+;;; run-vm-tests.scm -- Run Guile-VM's test suite.
+;;;
+;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(use-modules (system vm vm)
+ (system base compile)
+ (system base language)
+ (language scheme spec)
+ (language objcode spec)
+ (srfi srfi-1)
+ (ice-9 r5rs))
+
+\f
+(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 sexp #:from scheme #:to objcode))
+
+(define (run-vm-program objcode)
+ "Run VM program contained into @var{objcode}."
+ (vm-load (the-vm) objcode))
+
+(define (compile/run-test-from-file file)
+ "Run test from source file @var{file} and return a value indicating whether
+it succeeded."
+ (run-vm-program (compile-to-objcode (fetch-sexp-from-file file))))
+
+\f
+(define-macro (watch-proc proc-name str)
+ `(let ((orig-proc ,proc-name))
+ (set! ,proc-name
+ (lambda args
+ (format #t (string-append ,str "... "))
+ (apply orig-proc args)))))
+
+(watch-proc fetch-sexp-from-file "reading")
+(watch-proc compile-to-objcode "compiling")
+(watch-proc run-vm-program "running")
+
+\f
+;; The program.
+
+(define (run-vm-tests files)
+ "For each file listed in @var{files}, load it and run it through both the
+interpreter and the VM (after having it compiled). Both results must be
+equal in the sense of @var{equal?}."
+ (let* ((res (map (lambda (file)
+ (format #t "running `~a'... " file)
+ (if (catch #t
+ (lambda ()
+ (equal? (compile/run-test-from-file file)
+ (eval (fetch-sexp-from-file file)
+ (interaction-environment))))
+ (lambda (key . args)
+ (format #t "[~a/~a] " key args)
+ #f))
+ (format #t "ok~%")
+ (begin (format #t "FAILED~%") #f)))
+ files))
+ (total (length files))
+ (failed (length (filter not res))))
+
+ (if (= 0 failed)
+ (begin
+ (format #t "~%All ~a tests passed~%" total)
+ (exit 0))
+ (begin
+ (format #t "~%~a tests failed out of ~a~%"
+ failed total)
+ (exit failed)))))
+
--- /dev/null
+;;; Basic RnRS constructs.
+
+(and (eq? 2 (begin (+ 2 4) 5 2))
+ ((lambda (x y)
+ (and (eq? x 1) (eq? y 2)
+ (begin
+ (set! x 11) (set! y 22)
+ (and (eq? x 11) (eq? y 22)))))
+ 1 2)
+ (let ((x 1) (y 3))
+ (and (eq? x 1) (eq? y 3)))
+ (let loop ((x #t))
+ (if (not x)
+ #t
+ (loop #f))))
+
--- /dev/null
+(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))
--- /dev/null
+;; Test that nonlocal exits of the VM work.
+
+(begin
+ (define (foo thunk)
+ (catch #t thunk (lambda args args)))
+ (foo
+ (lambda ()
+ (let ((a 'one))
+ (1+ a)))))
+
--- /dev/null
+(define func
+ (let ((x 2))
+ (lambda ()
+ (let ((x++ (+ 1 x)))
+ (set! x x++)
+ x++))))
+
+(list (func) (func) (func))
--- /dev/null
+
+(define (uid)
+ (let* ((x 2)
+ (do-uid (lambda ()
+ (let ((x++ (+ 1 x)))
+ (set! x x++)
+ x++))))
+ (do-uid)))
+
+(list (uid) (uid) (uid))
--- /dev/null
+(define (stuff)
+ (let* ((x 2)
+ (chbouib (lambda (z)
+ (+ 7 z x))))
+ (chbouib 77)))
+
+(stuff)
--- /dev/null
+(define (extract-symbols exp)
+ (define (process x out cont)
+ (cond ((pair? x)
+ (process (car x)
+ out
+ (lambda (car-x out)
+ ;; used to have a bug here whereby `x' was
+ ;; modified in the self-tail-recursion to (process
+ ;; (cdr x) ...), because we didn't allocate fresh
+ ;; externals when doing self-tail-recursion.
+ (process (cdr x)
+ out
+ (lambda (cdr-x out)
+ (cont (cons car-x cdr-x)
+ out))))))
+ ((symbol? x)
+ (cont x (cons x out)))
+ (else
+ (cont x out))))
+ (process exp '() (lambda (x out) out)))
+
+(extract-symbols '(a b . c))
--- /dev/null
+(let ((n+ 0))
+ (do ((n- 5 (1- n-))
+ (n+ n+ (1+ n+)))
+ ((= n- 0))
+ (format #f "n- = ~a~%" n-)))
--- /dev/null
+;; Are global bindings reachable at run-time? This relies on the
+;; `object-ref' and `object-set' instructions.
+
+(begin
+
+ (define the-binding "hello")
+
+ ((lambda () the-binding))
+
+ ((lambda () (set! the-binding "world")))
+
+ ((lambda () the-binding)))
+
--- /dev/null
+;; Check whether literal integers are correctly signed.
+
+(and (= 4294967295 (- (expt 2 32) 1)) ;; unsigned
+ (= -2147483648 (- (expt 2 31))) ;; signed
+ (= 2147483648 (expt 2 31))) ;; unsigned
--- /dev/null
+;; Are built-in macros well-expanded at compilation-time?
+
+(false-if-exception (+ 2 2))
+(read-options)
--- /dev/null
+;; Are macros well-expanded at compilation-time?
+
+(defmacro minus-binary (a b)
+ `(- ,a ,b))
+
+(define-macro (plus . args)
+ `(let ((res (+ ,@args)))
+ ;;(format #t "plus -> ~a~%" res)
+ res))
+
+\f
+(plus (let* ((x (minus-binary 12 7)) ;; 5
+ (y (minus-binary x 1))) ;; 4
+ (plus x y 5)) ;; 14
+ 12 ;; 26
+ (expt 2 3)) ;; => 34
+
--- /dev/null
+; Currently, map is a C function, so this is a way of testing that the
+; VM is reentrant.
+
+(begin
+
+ (define (square x)
+ (* x x))
+
+ (map (lambda (x) (square x))
+ '(1 2 3)))
--- /dev/null
+;;; Pattern matching with `(ice-9 match)'.
+;;;
+
+(use-modules (ice-9 match)
+ (srfi srfi-9)) ;; record type (FIXME: See `t-records.scm')
+
+(define-record-type <stuff>
+ (%make-stuff chbouib)
+ stuff?
+ (chbouib stuff:chbouib stuff:set-chbouib!))
+
+(define (matches? obj)
+; (format #t "matches? ~a~%" obj)
+ (match obj
+ (($ stuff) => #t)
+; (blurps #t)
+ ("hello" #t)
+ (else #f)))
+
+\f
+;(format #t "go!~%")
+(and (matches? (%make-stuff 12))
+ (matches? (%make-stuff 7))
+ (matches? "hello")
+; (matches? 'blurps)
+ (not (matches? 66)))
--- /dev/null
+(define (even? x)
+ (or (zero? x)
+ (not (odd? (1- x)))))
+
+(define (odd? x)
+ (not (even? (1- x))))
+
+(even? 20)
--- /dev/null
+;; all the different permutations of or
+(list
+ ;; not in tail position, no args
+ (or)
+ ;; not in tail position, one arg
+ (or 'what)
+ (or #f)
+ ;; not in tail position, two arg
+ (or 'what 'where)
+ (or #f 'where)
+ (or #f #f)
+ (or 'what #f)
+ ;; 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))))
--- /dev/null
+(define the-struct (vector 1 2))
+
+(define get/set
+ (make-procedure-with-setter
+ (lambda (struct name)
+ (case name
+ ((first) (vector-ref struct 0))
+ ((second) (vector-ref struct 1))
+ (else #f)))
+ (lambda (struct name val)
+ (case name
+ ((first) (vector-set! struct 0 val))
+ ((second) (vector-set! struct 1 val))
+ (else #f)))))
+
+(and (eq? (vector-ref the-struct 0) (get/set the-struct 'first))
+ (eq? (vector-ref the-struct 1) (get/set the-struct 'second))
+ (begin
+ (set! (get/set the-struct 'second) 77)
+ (eq? (vector-ref the-struct 1) (get/set the-struct 'second))))
--- /dev/null
+(list
+ `()
+ `foo
+ `(foo)
+ `(foo bar)
+ `(1 2)
+ (let ((x 1)) `,x)
+ (let ((x 1)) `(,x))
+ (let ((x 1)) ``(,x))
+ (let ((head '(a b))
+ (tail 'c))
+ `(,@head . ,tail)))
--- /dev/null
+;;; SRFI-9 Records.
+;;;
+
+(use-modules (srfi srfi-9))
+
+(define-record-type <stuff>
+ (%make-stuff chbouib)
+ stuff?
+ (chbouib stuff:chbouib stuff:set-chbouib!))
+
+\f
+(and (stuff? (%make-stuff 12))
+ (= 7 (stuff:chbouib (%make-stuff 7)))
+ (not (stuff? 12))
+ (not (false-if-exception (%make-stuff))))
--- /dev/null
+(list (call-with-values
+ (lambda () (values 1 2))
+ (lambda (x y) (cons x y)))
+
+ ;; the start-stack forces a bounce through the interpreter
+ (call-with-values
+ (lambda () (start-stack 'foo (values 1 2)))
+ list)
+
+ (call-with-values
+ (lambda () (apply values '(1)))
+ list))
+
--- /dev/null
+-*- Outline -*-
+
+Once (system vm assemble) is compiled, things start to fail in
+unpredictable ways.
+
+* `compile-file' of non-closure-using programs works
+
+$ guile-disasm t-records.go > t-records.ref.asm
+...
+$ diff -uBb t-macros.*.asm
+$ diff -uBb t-records.*.asm
+$ diff -uBb t-global-bindings.*.asm
+
+* `compile-file' of closure-using programs fails
+
+ERROR: During compiling t-closure.scm:
+ERROR: VM: Wrong type to apply: #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) [IP offset: 28]
+
+guile> (vm-debugger (the-vm))
+debug> bt
+#1 #<variable 30b12468 value: (#(<glil-asm> #(<glil-vars> ((nargs . 0) (nrest . 0) (nlocs . 0) (nexts . 1))) (#(<glil-const> 2) #(<glil-bind> ((x external 0))) #(<glil-external> set 0 0) #(<glil-asm> #(<glil-vars> ((nargs . 0) (nrest . 0) (nlocs . 1) (nexts . 0))) (#(<glil-module> ref #f +) #(<glil-const> 1) #(<glil-external> ref 1 0) #(<glil-call> call 2) #(<glil-source> (2 . 15)) #(<glil-bind> ((x++ local 0))) #(<glil-local> set 0) #(<glil-local> ref 0) #(<glil-external> set 1 0) #(<glil-local> ref 0) #(<glil-call> return 0) #(<glil-unbind>))) #(<glil-call> return 0) #(<glil-unbind>))) #<directory (guile-user) 100742d0> ())>
+#2 (#<program 30ae74b8> #(<glil-vars> ...) (#(<glil-const> ...) #(<glil-bind> ...) ...))
+#3 (#<program 30af7090>)
+#4 (#<program 30af94c0> #(<glil-vars> ...) (#(<glil-module> ...) #(<glil-const> ...) ...))
+#5 (#<program 30b00108>)
+#6 (#<program 30b02590> ref ...)
+#7 (_l 1 #(<venv> ...))
+guile> (vm-debugger (the-vm))
+debug> stack
+(#t closure? #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) #<procedure #f (struct name val)> #<primitive-generic map> #<primitive-generic map> #<program 30998470>)
+
+* Compiling anything "by hand" fails
+
+** Example 1: the read/compile/run loop
+
+guile> (set! %load-path (cons "/home/ludo/src/guile-vm/module" %load-path))
+guile> (use-modules (system vm assemble)(system vm core)(system repl repl))
+guile> (start-repl 'scheme)
+Guile Scheme interpreter 0.5 on Guile 1.7.2
+Copyright (C) 2001 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+scheme@guile-user> (use-modules (ice-9 match)
+ (system base syntax)
+ (system vm assemble))
+
+(define (%preprocess x e)
+ (match x
+ (($ <glil-asm> vars body)
+ (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
+ (body (map (lambda (x) (preprocess x venv)) body)))
+ (<vm-asm> :venv venv :glil x :body body)))
+ (($ <glil-external> op depth index)
+ (do ((d depth (1- d))
+ (e e (slot e 'parent)))
+ ((= d 0))
+ (set! (slot e 'closure?) #t))
+ x)
+ (else x)))
+
+scheme@guile-user> preprocess
+#<procedure preprocess (x e)>
+scheme@guile-user> (getpid)
+470
+scheme@guile-user> (set! preprocess %preprocess)
+scheme@guile-user> preprocess
+ERROR: VM: Unbound variable: #<variable 30a0d5e0 value: #<undefined>>
+scheme@guile-user> getpid
+ERROR: VM: Unbound variable: #<variable 30a0d5e0 value: #<undefined>>
+scheme@guile-user>
+
+
+** Example 2: the test suite (which also reads/compiles/runs)
+
+All the closure-using tests fail.
+
+ludo@lully:~/src/guile-vm/testsuite $ make check
+../src/guile-vm -L ../module \
+ -l run-vm-tests.scm -e run-vm-tests \
+ t-global-bindings.scm t-closure.scm t-closure2.scm t-closure3.scm t-do-loop.scm t-macros.scm t-proc-with-setter.scm t-values.scm t-records.scm t-match.scm
+
+running `t-global-bindings.scm'... reading... compiling... running... ok
+running `t-closure.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-closure2.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 0) (closure? . #f)))) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-closure3.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong ype to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 0) (closure? . #f)))) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-do-loop.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-macros.scm'... reading... compiling... running... ok
+running `t-proc-with-setter.scm'... reading... compiling... running... ok
+running `t-values.scm'... reading... compiling... running... ok
+running `t-records.scm'... reading... compiling... running... ok
+running `t-match.scm'... reading... compiling... running... ok
+
+4 tests failed out of 10
+make: *** [check] Error 4
+
HCoop / bpt / guile.git / commitdiff