From a98cef7e6c42d40c8d77640030d3eb2697ae647b Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 15:54:19 +0000 Subject: Initial revision --- AUTHORS | 1 + ChangeLog | 12 + Makefile.am | 7 + NEWS | 0 README | 0 THANKS | 1 + acconfig.h | 4 + acinclude.m4 | 20 + autogen.sh | 6 + configure.in | 15 + doc/Makefile.am | 2 + doc/goops.mail | 78 ++++ doc/vm-spec.txt | 402 +++++++++++++++++ src/Makefile.am | 47 ++ src/guile-compile.in | 6 + src/guile-vm.c | 58 +++ src/test.scm | 60 +++ src/vm-snarf.h | 88 ++++ src/vm.c | 1221 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/vm.h | 226 ++++++++++ src/vm_engine.c | 132 ++++++ src/vm_engine.h | 345 ++++++++++++++ src/vm_number.c | 188 ++++++++ src/vm_scheme.c | 111 +++++ src/vm_system.c | 549 +++++++++++++++++++++++ test/Makefile.am | 16 + test/control.scm | 20 + test/procedure.scm | 60 +++ test/queens.scm | 50 +++ test/test.scm | 12 + vm/Makefile.am | 14 + vm/bytecomp.scm | 500 +++++++++++++++++++++ vm/compile.scm | 310 +++++++++++++ vm/shell.scm | 221 +++++++++ vm/types.scm | 367 +++++++++++++++ vm/utils.scm | 106 +++++ 36 files changed, 5255 insertions(+) create mode 100644 AUTHORS create mode 100644 ChangeLog create mode 100644 Makefile.am create mode 100644 NEWS create mode 100644 README create mode 100644 THANKS create mode 100644 acconfig.h create mode 100644 acinclude.m4 create mode 100755 autogen.sh create mode 100644 configure.in create mode 100644 doc/Makefile.am create mode 100644 doc/goops.mail create mode 100644 doc/vm-spec.txt create mode 100644 src/Makefile.am create mode 100644 src/guile-compile.in create mode 100644 src/guile-vm.c create mode 100644 src/test.scm create mode 100644 src/vm-snarf.h create mode 100644 src/vm.c create mode 100644 src/vm.h create mode 100644 src/vm_engine.c create mode 100644 src/vm_engine.h create mode 100644 src/vm_number.c create mode 100644 src/vm_scheme.c create mode 100644 src/vm_system.c create mode 100644 test/Makefile.am create mode 100644 test/control.scm create mode 100644 test/procedure.scm create mode 100644 test/queens.scm create mode 100644 test/test.scm create mode 100644 vm/Makefile.am create mode 100644 vm/bytecomp.scm create mode 100644 vm/compile.scm create mode 100644 vm/shell.scm create mode 100644 vm/types.scm create mode 100644 vm/utils.scm diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 000000000..fd76e9211 --- /dev/null +++ b/AUTHORS @@ -0,0 +1 @@ +Keisuke Nishida diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 000000000..56b451d7b --- /dev/null +++ b/ChangeLog @@ -0,0 +1,12 @@ +2000-08-20 Keisuke Nishida + + * Version 0.2 is released. + +2000-08-12 Keisuke Nishida + + * Version 0.1 is released. + +2000-07-29 Keisuke Nishida + + * Version 0.0 is released. + diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 000000000..e38d314b0 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,7 @@ +SUBDIRS = src vm doc test + +EXTRA_DIST = acconfig.h + +MAINTAINERCLEANFILES = COPYING INSTALL config.guess config.sub ltconfig \ + ltmain.sh Makefile.in aclocal.m4 config.h.in stamp-h.in \ + configure missing mkinstalldirs install-sh texinfo.tex diff --git a/NEWS b/NEWS new file mode 100644 index 000000000..e69de29bb diff --git a/README b/README new file mode 100644 index 000000000..e69de29bb diff --git a/THANKS b/THANKS new file mode 100644 index 000000000..da16a3a50 --- /dev/null +++ b/THANKS @@ -0,0 +1 @@ +Guile VM is motivated by QScheme. diff --git a/acconfig.h b/acconfig.h new file mode 100644 index 000000000..834401771 --- /dev/null +++ b/acconfig.h @@ -0,0 +1,4 @@ +/* Define if compiler supports gcc's "labels as values" (aka computed goto) + * feature (which is used to speed up instruction dispatch in the interpreter). + */ +#undef HAVE_LABELS_AS_VALUES diff --git a/acinclude.m4 b/acinclude.m4 new file mode 100644 index 000000000..5f8e76612 --- /dev/null +++ b/acinclude.m4 @@ -0,0 +1,20 @@ +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) +fi +]) diff --git a/autogen.sh b/autogen.sh new file mode 100755 index 000000000..15741faed --- /dev/null +++ b/autogen.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +aclocal +autoheader +automake -a +autoconf diff --git a/configure.in b/configure.in new file mode 100644 index 000000000..d0f58bb29 --- /dev/null +++ b/configure.in @@ -0,0 +1,15 @@ +AC_INIT(src/guile-vm.c) +AM_INIT_AUTOMAKE(guile-vm, 0.2) +AM_CONFIG_HEADER(src/config.h) + +GUILE_FLAGS +if test "`guile -c '(display (string>=? (version) "1.4.1"))'`" != "#t"; then + AC_MSG_ERROR([Your Guile is too old. You need guile-1.4.1 or later.]) +fi + +AC_PROG_CC +AC_PROG_LN_S +AM_PROG_LIBTOOL +AC_C_LABELS_AS_VALUES + +AC_OUTPUT(Makefile src/Makefile vm/Makefile doc/Makefile test/Makefile) diff --git a/doc/Makefile.am b/doc/Makefile.am new file mode 100644 index 000000000..3ab2c4b5b --- /dev/null +++ b/doc/Makefile.am @@ -0,0 +1,2 @@ +EXTRA_DIST = vm-spec.txt +MAINTAINERCLEANFILES = Makefile.in diff --git a/doc/goops.mail b/doc/goops.mail new file mode 100644 index 000000000..305e80403 --- /dev/null +++ b/doc/goops.mail @@ -0,0 +1,78 @@ +From: Mikael Djurfeldt +Subject: Re: After GOOPS integration: Computation with native types! +To: Keisuke Nishida +Cc: djurfeldt@nada.kth.se, guile@sourceware.cygnus.com +Cc: djurfeldt@nada.kth.se +Date: 17 Aug 2000 03:01:13 +0200 + +Keisuke Nishida writes: + +> Do I need to include some special feature in my VM? Hmm, but maybe +> I shouldn't do that now... + +Probably not, so I probably shouldn't answer, but... :) + +You'll need to include some extremely efficient mechanism to do +multi-method dispatch. The SCM_IM_DISPATCH form, with its +implementation at line 2250 in eval.c, is the current basis for +efficient dispatch in GOOPS. + +I think we should develop a new instruction for the VM which +corresponds to the SCM_IM_DISPATCH form. + +This form serves both the purpose to map argument types to the correct +code, and as a cache of compiled methods. + +Notice that I talk about cmethods below, not methods. In GOOPS, the +GF has a set of methods, but each method has a "code-table" mapping +argument types to code compiled for those particular concrete types. +(So, in essence, GOOPS methods abstractly do a deeper level of type +dispatch.) + +The SCM_IM_DISPATCH form has two shapes, depending on whether we use +sequential search (few cmethods) or hashed lookup (many cmethods). + +Shape 1: + + (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF) + +Shape 2: + + (#@dispatch args N-SPECIALIZED HASHSET MASK + #((TYPE1 ... ENV FORMALS FORM1 ...) ...) + GF) + +`args' is (I hope!) a now historic obscure optimization. + +N-SPECIALIZED is the maximum number of arguments t do type checking +on. This is used early termination of argument checking where the +already checked arguments are enough to pick out the cmethod. + +The vector is the cache proper. + +During sequential search the argument types are simply checked against +each entry. + +The method for hashed dispatch is described in: + +http://www.parc.xerox.com/csl/groups/sda/publications/papers/Kiczales-Andreas-PCL + +In this method, each class has a hash code. Dispatch means summing +the hash codes for all arguments (up til N-SPECIALIZED) and using the +sum to pick a location in the cache. The cache is sequentially +searched for an argument type match from that point. + +Kiczales introduced a clever method to maximize the probability of a +direct cache hit. We actually have 8 separate sets of hash codes for +all types. The hash set to use is selected specifically per GF and is +optimized to give fastest average hit. + + +What we could try to do as soon as the VM is complete enough is to +represent the cmethods as chunks of byte code. In the current GOOPS +code, the compilation step (which is currently empty) is situated in +`compile-cmethod' in guile-oops/compile.scm. [Apologies for the +terrible code. That particular part was written at Arlanda airport +after a sleepless night (packing luggage, not coding), on my way to +visit Marius (who, BTW, didn't take GOOPS seriously. ;-)] + diff --git a/doc/vm-spec.txt b/doc/vm-spec.txt new file mode 100644 index 000000000..e3a04f5f1 --- /dev/null +++ b/doc/vm-spec.txt @@ -0,0 +1,402 @@ +Guile VM Specification -*- outline -*- +====================== +Updated: $Date: 2000/08/22 15:54:19 $ + +* Introduction + +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. + +** Registers + + pc - Program counter ;; ip (instruction poiner) is better? + sp - Stack pointer + bp - Base pointer + ac - Accumulator + +** 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. + +** 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. + +** 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. + +** 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. + +* Variable Management + +A program may have access to local variables, external variables, and +top-level variables. + +** 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. + + 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| | | + | +----------+ - | + | | | | | + +The first block of each frame may look like this: + + 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) + +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. + + local external + chain| | chain + | +-----+ .--------, | + `-|block|--+->|fragment|-' + /+-----+ | `--------'\, + `-|block|--' | + /+-----+ .--------, | + `-|block|---->|fragment|-' + +-----+ `--------' + | | + +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. + +** 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. + +*** Scheme and VM variable + +Let's think about the following Scheme code as an example: + + (define (foo a) + (lambda (b) (list foo a b))) + +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: + + block Top-level: foo + +-------------+ + |local var: b | fragment + +-------------+ .-----------, + |external link|---->|variable: a| + +-------------+ `-----------' + +The fragment remains as long as the closure exists. + +** Addressing mode + +Guile VM has five addressing modes: + + o Real address + o Local position + o External position + o Top-level location + o Immediate object + +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. + +Immediate object is not an address but gives an instruction an Scheme +object directly. + +[ We'll also need dynamic scope addressing to support Emacs Lisp? ] + +*** At a Glance + +Guile VM has a set of instructions for each instruction family. `%load' +is, for example, a family to load an object from memory and set the +accumulator (ac). There are four basic `%load' instructions: + + %loadl - Local addressing + %loade - External addressing + %loadt - Top-level addressing + %loadi - Immediate addressing + +A possible program code may look like this: + + %loadl (0 . 1) ; ac = local[0][1] + %loade (2 . 3) ; ac = external[2][3] + %loadt (foo . #) ; ac = # + %loadi "hello" ; ac = "hello" + +One instruction that uses real addressing is `%jump', which changes the +value of the program counter: + + %jump 0x80234ab8 ; pc = 0x80234ab8 + +* Program Execution + +Overall procedure: + + 1. A source program is compiled into a bytecode. + + 2. A bytecode is given an environment and becomes a program. + + 3. A VM starts execution, creating a frame for it. + + 4. Whenever a program calls a subprogram, a new frame is created for it. + + 5. When a program finishes execution, it returns a value, and the VM + continues execution of the parent program. + + 6. When all programs terminated, the VM returns the final value and stops. + +** Environment + +Local variable: + + (let ((a 1) (b 2) (c 3)) (+ a b c)) -> + + %pushi 1 ; a + %pushi 2 ; b + %pushi 3 ; c + %bind 3 ; create local bindings + %pushl (0 . 0) ; local variable a + %pushl (0 . 1) ; local variable b + %pushl (0 . 2) ; local variable c + add 3 ; ac = a + b + c + %unbind ; remove local bindings + +External variable: + + (define foo (let ((n 0)) (lambda () n))) + + %pushi 0 ; n + %bind 1 ; create local bindings + %export [0] ; make it an external variable + %make-program # ; create a program in this environment + %unbind ; remove local bindings + %savet (foo . #) ; save the program in foo + + (foo) -> + + %loadt (foo . #) ; program has an external link + %call 0 ; change the current external link + %loade (0 . 0) ; external variable n + %return ; recover the external link + +Top-level variable: + + foo -> + + %loadt (foo . #) ; top-level variable foo + +** Flow control + + (if #t 1 0) -> + + %loadi #t + %br-if-not L1 + %loadi 1 + %jump L2 + L1: %loadi 0 + L2: + +** Function call + +Builtin function: + + (1+ 2) -> + + %loadi 2 ; ac = 2 + 1+ ; one argument + + (+ 1 2) -> + + %pushi 1 ; 1 -> stack + %loadi 2 ; ac = 2 + add2 ; two argument + + (+ 1 2 3) -> + + %pushi 1 ; 1 -> stack + %pushi 2 ; 2 -> stack + %pushi 3 ; 3 -> stack + add 3 ; many argument + +External function: + + (version) -> + + %func0 (version . #) ; no argument + + (display "hello") -> + + %loadi "hello" + %func1 (display . #) ; one argument + + (open-file "file" "w") -> + + %pushi "file" + %loadi "w" + %func2 (open-file . #) ; two arguments + + (equal 1 2 3) + + %pushi 1 + %pushi 2 + %pushi 3 + %loadi 3 ; the number of arguments + %func (equal . #) ; many arguments + +** Subprogram call + + (define (plus a b) (+ a b)) + (plus 1 2) -> + + %pushi 1 ; argument 1 + %pushi 2 ; argument 2 + %loadt (plus . #) ; load the program + %call 2 ; call it with two arguments + %pushl (0 . 0) ; argument 1 + %loadl (0 . 1) ; argument 2 + add2 ; ac = 1 + 2 + %return ; result is 3 + +* 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. By convention, system instructions begin with a +letter `%'. + +** Environment control instructions + +- %alloc +- %bind +- %export +- %unbind + +** Subprogram control instructions + +- %make-program +- %call +- %return + +** Data control instructinos + +- %push +- %pushi +- %pushl, %pushl:0:0, %pushl:0:1, %pushl:0:2, %pushl:0:3 +- %pushe, %pushe:0:0, %pushe:0:1, %pushe:0:2, %pushe:0:3 +- %pusht + +- %loadi +- %loadl, %loadl:0:0, %loadl:0:1, %loadl:0:2, %loadl:0:3 +- %loade, %loade:0:0, %loade:0:1, %loade:0:2, %loade:0:3 +- %loadt + +- %savei +- %savel, %savel:0:0, %savel:0:1, %savel:0:2, %savel:0:3 +- %savee, %savee:0:0, %savee:0:1, %savee:0:2, %savee:0:3 +- %savet + +** Flow control instructions + +- %br-if +- %br-if-not +- %jump + +** Function call instructions + +- %func, %func0, %func1, %func2 + +** Scheme buitin functions + +- cons +- car +- cdr + +** Mathematical buitin functions + +- 1+ +- 1- +- add, add2 +- sub, sub2, minus +- mul2 +- div2 +- lt2 +- gt2 +- le2 +- ge2 +- num-eq2 diff --git a/src/Makefile.am b/src/Makefile.am new file mode 100644 index 000000000..552690df9 --- /dev/null +++ b/src/Makefile.am @@ -0,0 +1,47 @@ +bin_PROGRAMS = guile-vm +guile_vm_SOURCES = guile-vm.c +guile_vm_LDADD = libguilevm.la +guile_vm_LDFLAGS = $(GUILE_LDFLAGS) + +bin_SCRIPTS = guile-compile + +lib_LTLIBRARIES = libguilevm.la +libguilevm_la_SOURCES = vm.c +libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic +noinst_HEADERS = vm.h vm_engine.h vm-snarf.h +EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c \ + test.scm guile-compile.in +BUILT_SOURCES = vm_system.vi vm_scheme.vi vm_number.vi \ + vm_system.op vm_scheme.op vm_number.op vm.x + +CFLAGS = -g -O2 -Wall +INCLUDES = $(GUILE_CFLAGS) +CLEANFILES = $(bin_SCRIPTS) +DISTCLEANFILES = $(BUILT_SOURCES) +MAINTAINERCLEANFILES = Makefile.in config.h.in stamp-h.in + +SNARF = guile-snarf +SUFFIXES = .x .vi .op +.c.x: + $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ + || { rm $@; false; } + +.c.vi: + $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ + || { rm $@; false; } + +.c.op: + $(SNARF) -DSCM_SNARF_OPCODE $(DEFS) $(INCLUDES) $(CPPFLAGS) \ + $(CFLAGS) $< > $@ || { rm $@; false; } + +$(BUILT_SOURCES): config.h vm-snarf.h + +guile-compile: guile-compile.in + sed -e 's!\@bindir\@!$(bindir)!' -e 's!\@PACKAGE\@!$(PACKAGE)!' \ + $< > $@ + +test: all + $(bin_PROGRAMS) -s test.scm + +debug-test: all + $(bin_PROGRAMS) -s test.scm debug diff --git a/src/guile-compile.in b/src/guile-compile.in new file mode 100644 index 000000000..1589d220e --- /dev/null +++ b/src/guile-compile.in @@ -0,0 +1,6 @@ +#!@bindir@/@PACKAGE@ -s +!# + +(use-modules (vm compile)) + +(for-each compile-file (cdr (command-line))) diff --git a/src/guile-vm.c b/src/guile-vm.c new file mode 100644 index 000000000..5d3c1c1a6 --- /dev/null +++ b/src/guile-vm.c @@ -0,0 +1,58 @@ +/* Copyright (C) 2000 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. */ + +#include + +extern void scm_init_vm_vm_module (); + +static void +inner_main (void *closure, int argc, char **argv) +{ + scm_init_vm_vm_module (); + scm_shell (argc, argv); +} + +int +main (int argc, char **argv) +{ + scm_boot_guile (argc, argv, inner_main, 0); + return 0; /* never reached */ +} diff --git a/src/test.scm b/src/test.scm new file mode 100644 index 000000000..85d747fea --- /dev/null +++ b/src/test.scm @@ -0,0 +1,60 @@ + +(set! %load-path (cons ".." %load-path)) +(use-modules (vm vm)) +(use-modules (vm shell)) +(use-modules (vm compile)) +(use-modules (ice-9 syncase)) + +(define *verbose-output* (if (null? (cdr (command-line))) #f #t)) + +(define test-list + '((1 1) + ((1- 1) 0) + ((+ (+ 1) (- 2)) -1) + ((+ (+ 1 2) (- 1 2) (* 1 2) (/ 1 2)) 4.5) + ((* (- 1 2 3) (+ 1.2 3.4) (/ 1 2 4)) -2.3) + ((let ((a 1)) a) 1) + ((let ((a 1) (b 2)) b) 2) + ((let* ((a 1) (a 2)) a) 2) + ((let ((a 1)) (let ((b 2)) a)) 1) + ((let ((a 1) (b 2) (c 3)) + ((lambda (d e f) + ((lambda (g h i) + ((lambda () (list a b d f h i)))) + 7 8 9)) + 4 5 6)) + (1 2 4 6 8 9)) + ((do ((i 3 (1- i)) (n 0 (+ n i))) ((< i 0) n)) 6) + ((let () (define (foo a) a) (foo 1)) 1) + ((begin (define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) + (fib 3)) 2) + ((begin (define (loop i l) (if (< i l) (loop (+ 1 i) l) l)) + (loop 0 3)) 3) +; ((call-with-current-continuation (lambda (c) (c 1) 2)) 1) + ((map 1+ '(1 2 3)) (2 3 4)) + )) + +(define (test vm form answer) + (format #t "Testing ~S = ~S ..." form answer) + (let ((result (vm-run vm (compile form)))) + (if (equal? result answer) + (display "OK\n") + (format #t "failed: ~S\n" result)))) + +(define (debug-test vm form answer) + (format #t "Testing ~S = ~S ...\n" form answer) + (let ((result (begin + (vm-set-option! vm 'verbose *verbose-output*) + (vm-trace vm form)))) + (if (equal? result answer) + (display "OK\n") + (format #t "failed: ~S\n" result)))) + +(let ((vm (make-vm))) + (display "=== Testing the debug engine ===\n") + (vm-set-option! vm 'debug #t) + (for-each (lambda (q) (apply debug-test vm q)) test-list) + (display "\n=== Testing the fast engine ===\n") + (vm-set-option! vm 'debug #f) + (for-each (lambda (q) (apply test vm q)) test-list) + (display "done\n")) diff --git a/src/vm-snarf.h b/src/vm-snarf.h new file mode 100644 index 000000000..8956e32c9 --- /dev/null +++ b/src/vm-snarf.h @@ -0,0 +1,88 @@ +/* Copyright (C) 2000 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_SNARF_H +#define VM_SNARF_H + +#include "config.h" + +#define VM_LABEL(TAG) l_##TAG## +#define VM_OPCODE(TAG) 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 */ + +#ifndef SCM_MAGIC_SNARFER + +/* + * These are directly included in vm_engine.c + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_TAG(TAG) +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_TAG(TAG) + +#else /* SCM_MAGIC_SNARFER */ +#ifndef SCM_SNARF_OPCODE + +/* + * These will go to *.vi + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ + SCM_SNARF_INIT_START {VM_OPCODE(TAG), TYPE, NAME, VM_ADDR(TAG), SCM_BOOL_F, NULL, 0, 0}, +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ + SCM_SNARF_INIT_START {VM_OPCODE(TAG), INST_NONE, NAME, VM_ADDR(TAG), SCM_BOOL_F, SNAME, NARGS, RESTP}, + +#else /* SCM_SNARF_OPCODE */ + +/* + * These will go to *.op + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) SCM_SNARF_INIT_START VM_OPCODE(TAG), +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) SCM_SNARF_INIT_START VM_OPCODE(TAG), + +#endif /* SCM_SNARF_OPCODE */ +#endif /* SCM_MAGIC_SNARFER */ + +#endif /* not VM_SNARF_H */ diff --git a/src/vm.c b/src/vm.c new file mode 100644 index 000000000..51fa23a8c --- /dev/null +++ b/src/vm.c @@ -0,0 +1,1221 @@ +/* Copyright (C) 2000 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. */ + +#define SCM_DEBUG_TYPING_STRICTNESS 0 +#include "config.h" +#include "vm.h" + +/* default stack size in the number of SCM */ +#define VM_DEFAULT_STACK_SIZE (1 * 1024) /* = 128KB */ +#define VM_MAXIMUM_STACK_SIZE (1024 * 1024) /* = 4MB */ + +/* I sometimes use this for debugging. */ +#define vm_puts(OBJ) \ +{ \ + scm_display (OBJ, scm_def_errp); \ + scm_newline (scm_def_errp); \ +} + + +/* + * Instruction + */ + +#define INSTRUCTION_HASH_SIZE op_last +#define INSTRUCTION_HASH(ADDR) (((int) (ADDR) >> 1) % INSTRUCTION_HASH_SIZE) + +/* These variables are defined in VM engines when they are first called. */ +static struct scm_instruction *scm_regular_instruction_table = 0; +static struct scm_instruction *scm_debug_instruction_table = 0; + +/* Hash table for finding instructions from addresses */ +static struct inst_hash { + void *addr; + struct scm_instruction *inst; + struct inst_hash *next; +} *scm_instruction_hash_table[INSTRUCTION_HASH_SIZE]; + +static long scm_instruction_tag; + +static SCM +make_instruction (struct scm_instruction *instp) +{ + SCM_RETURN_NEWSMOB (scm_instruction_tag, instp); +} + +static int +print_instruction (SCM obj, SCM port, scm_print_state *pstate) +{ + scm_puts ("#name, port); + scm_putc ('>', port); + return 1; +} + +static void +init_instruction_type () +{ + scm_instruction_tag = scm_make_smob_type ("instruction", 0); + scm_set_smob_print (scm_instruction_tag, print_instruction); +} + +/* C interface */ + +static struct scm_instruction * +find_instruction_by_name (const char *name) +{ + struct scm_instruction *p; + for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + if (strcmp (name, p->name) == 0) + return p; + return 0; +} + +static struct scm_instruction * +find_instruction_by_code (SCM code) +{ + struct inst_hash *p; + void *addr = SCM_CODE_TO_ADDR (code); + for (p = scm_instruction_hash_table[INSTRUCTION_HASH (addr)]; p; p = p->next) + if (p->addr == addr) + return p->inst; + return 0; +} + +#ifdef HAVE_LABELS_AS_VALUES +static void * +instruction_code_to_debug_addr (SCM code) +{ + struct scm_instruction *p = find_instruction_by_code (code); + return scm_debug_instruction_table[p->opcode].addr; +} +#endif + +/* Scheme interface */ + +SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_instruction_p +{ + return SCM_BOOL (SCM_INSTRUCTION_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_system_instruction_p, "system-instruction?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_system_instruction_p +{ + return SCM_BOOL (SCM_SYSTEM_INSTRUCTION_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_functional_instruction_p, "functional-instruction?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_functional_instruction_p +{ + return SCM_BOOL (SCM_FUNCTIONAL_INSTRUCTION_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_name_p, "instruction-name?", 1, 0, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_instruction_name_p +{ + SCM_VALIDATE_SYMBOL (1, name); + return SCM_BOOL (find_instruction_by_name (SCM_CHARS (name))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_symbol_to_instruction, "symbol->instruction", 1, 0, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_symbol_to_instruction +{ + struct scm_instruction *p; + SCM_VALIDATE_SYMBOL (1, name); + + p = find_instruction_by_name (SCM_CHARS (name)); + if (!p) + SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name)); + + return p->obj; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_instruction_list +{ + SCM list = SCM_EOL; + struct scm_instruction *p; + for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + list = scm_cons (p->obj, list); + return scm_reverse_x (list, SCM_EOL); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_opcode, "instruction-opcode", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_opcode +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->opcode); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_name, "instruction-name", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_name +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->name)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_type, "instruction-type", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_type +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->type); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_scheme_name, "instruction-scheme-name", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_scheme_name +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + if (SCM_FUNCTIONAL_INSTRUCTION_P (inst)) + return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->sname)); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_arity, "instruction-arity", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_arity +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + if (SCM_FUNCTIONAL_INSTRUCTION_P (inst)) + { + struct scm_instruction *p = SCM_INSTRUCTION_DATA (inst); + return SCM_LIST2 (SCM_MAKINUM (p->nargs), SCM_BOOL (p->restp)); + } + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +/* + * Bytecode + */ + +static long scm_bytecode_tag; + +static SCM +make_bytecode (int size) +{ + struct scm_bytecode *p + = scm_must_malloc (sizeof (*p) + (size * sizeof (SCM)), "make_bytecode"); + p->size = size; + SCM_RETURN_NEWSMOB (scm_bytecode_tag, p); +} + +static SCM +mark_bytecode (SCM bytecode) +{ + int i; + struct scm_instruction *p; + + int size = SCM_BYTECODE_SIZE (bytecode); + SCM *base = SCM_BYTECODE_BASE (bytecode); + + for (i = 0; i < size; i++) + { + p = find_instruction_by_code (base[i]); + switch (p->type) + { + case INST_NONE: + break; + case INST_SCM: + case INST_TOP: + case INST_EXT: + case INST_CODE: + scm_gc_mark (base[++i]); + break; + case INST_INUM: /* a fixed integer; we don't need to mark it */ + case INST_ADDR: /* real memory address; we shouldn't mark it! */ + i++; + } + } + return SCM_BOOL_F; +} + +static int +print_bytecode (SCM obj, SCM port, scm_print_state *pstate) +{ + scm_puts ("#', port); + return 1; +} + +static scm_sizet +free_bytecode (SCM bytecode) +{ + int size = (sizeof (struct scm_bytecode) + + (SCM_BYTECODE_SIZE (bytecode) * sizeof (SCM))); + if (SCM_BYTECODE_EXTS (bytecode)) + { + size += (SCM_BYTECODE_EXTS (bytecode)[0] + 1) * sizeof (int); + scm_must_free (SCM_BYTECODE_EXTS (bytecode)); + } + scm_must_free (SCM_BYTECODE_DATA (bytecode)); + return size; +} + +static void +init_bytecode_type () +{ + scm_bytecode_tag = scm_make_smob_type ("bytecode", 0); + scm_set_smob_mark (scm_bytecode_tag, mark_bytecode); + scm_set_smob_print (scm_bytecode_tag, print_bytecode); + scm_set_smob_free (scm_bytecode_tag, free_bytecode); +} + +/* Scheme interface */ + +SCM_DEFINE (scm_bytecode_p, "bytecode?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_bytecode_p +{ + return SCM_BOOL (SCM_BYTECODE_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0, + (SCM code), +"") +#define FUNC_NAME s_scm_make_bytecode +{ + int i, size, len, offset; + SCM header, body, nreqs, restp, nvars, nexts, exts, bytecode; + SCM *old, *new, *address; + + /* Type check */ + SCM_VALIDATE_VECTOR (1, code); + SCM_ASSERT_RANGE (1, code, SCM_LENGTH (code) == 2); + header = SCM_VELTS (code)[0]; + body = SCM_VELTS (code)[1]; + SCM_VALIDATE_VECTOR (1, header); + SCM_VALIDATE_VECTOR (2, body); + SCM_ASSERT_RANGE (1, header, SCM_LENGTH (header) == 5); + nreqs = SCM_VELTS (header)[0]; + restp = SCM_VELTS (header)[1]; + nvars = SCM_VELTS (header)[2]; + nexts = SCM_VELTS (header)[3]; + exts = SCM_VELTS (header)[4]; + SCM_VALIDATE_INUM (1, nreqs); + SCM_VALIDATE_BOOL (2, restp); + SCM_VALIDATE_INUM (3, nvars); + SCM_VALIDATE_INUM (4, nexts); + SCM_VALIDATE_VECTOR (5, exts); + + /* Create a new bytecode */ + size = SCM_LENGTH (body); + old = SCM_VELTS (body); + bytecode = make_bytecode (size); + new = SCM_BYTECODE_BASE (bytecode); + + /* Initialize the header */ + SCM_BYTECODE_NREQS (bytecode) = SCM_INUM (nreqs); + SCM_BYTECODE_RESTP (bytecode) = SCM_FALSEP (restp) ? 0 : 1; + SCM_BYTECODE_NVARS (bytecode) = SCM_INUM (nvars); + SCM_BYTECODE_NEXTS (bytecode) = SCM_INUM (nexts); + len = SCM_LENGTH (exts); + if (len == 0) + { + SCM_BYTECODE_EXTS (bytecode) = NULL; + } + else + { + SCM_BYTECODE_EXTS (bytecode) = + scm_must_malloc ((len + 1) * sizeof (int), FUNC_NAME); + SCM_BYTECODE_EXTS (bytecode)[0] = len; + for (i = 0; i < len; i++) + SCM_BYTECODE_EXTS (bytecode)[i + 1] = SCM_INUM (SCM_VELTS (exts)[i]); + } + + /* Initialize the body */ + for (i = 0; i < size; i++) + { + struct scm_instruction *p; + + /* Process instruction */ + if (!SCM_SYMBOLP (old[i]) + || !(p = find_instruction_by_name (SCM_CHARS (old[i])))) + SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old[i])); + new[i] = SCM_ADDR_TO_CODE (p->addr); + + /* Process arguments */ + if (p->type == INST_NONE) + continue; + if (++i >= size) + SCM_MISC_ERROR ("Unexpected end of code", SCM_EOL); + switch (p->type) + { + case INST_NONE: + /* never come here */ + case INST_INUM: + SCM_VALIDATE_INUM (1, old[i]); + /* fall through */ + case INST_SCM: + /* just copy */ + new[i] = old[i]; + break; + case INST_TOP: + /* top-level variable */ + SCM_VALIDATE_SYMBOL (1, old[i]); + new[i] = scm_intern0 (SCM_CHARS (old[i])); + break; + case INST_EXT: + /* just copy for now */ + SCM_VALIDATE_CONS (1, old[i]); + SCM_VALIDATE_INUM (1, SCM_CAR (old[i])); + SCM_VALIDATE_INUM (1, SCM_CDR (old[i])); + new[i] = old[i]; + break; + case INST_CODE: + /* another bytecode */ + new[i] = scm_make_bytecode (old[i]); + break; + case INST_ADDR: + /* real address */ + SCM_VALIDATE_INUM (1, old[i]); + /* Without the following intermediate variables, type conversion + fails on my machine. Casting doesn't work well, why? */ + offset = SCM_INUM (old[i]); + address = new + offset; + new[i] = SCM_VM_MAKE_ADDRESS (address); + break; + } + } + return bytecode; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytecode_decode, "bytecode-decode", 1, 0, 0, + (SCM bytecode), +"") +#define FUNC_NAME s_scm_bytecode_decode +{ + int i, size, offset; + SCM code, *old, *new; + + SCM_VALIDATE_BYTECODE (1, bytecode); + + size = SCM_BYTECODE_SIZE (bytecode); + old = SCM_BYTECODE_BASE (bytecode); + code = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); + new = SCM_VELTS (code); + + for (i = 0; i < size; i++) + { + struct scm_instruction *p; + + /* Process instruction */ + p = find_instruction_by_code (old[i]); + if (!p) + { + broken: + SCM_MISC_ERROR ("Broken bytecode", SCM_EOL); + } + new[i] = scm_instruction_name (p->obj); + + /* Process arguments */ + if (p->type == INST_NONE) + continue; + if (++i >= size) + goto broken; + switch (p->type) + { + case INST_NONE: + /* never come here */ + case INST_INUM: + case INST_SCM: + case INST_EXT: + /* just copy */ + new[i] = old[i]; + break; + case INST_TOP: + /* top-level variable */ + new[i] = SCM_CAR (old[i]); + break; + case INST_CODE: + /* another bytecode */ + new[i] = scm_bytecode_decode (old[i]); + break; + case INST_ADDR: + /* program address */ + offset = SCM_VM_ADDRESS (old[i]) - old; + new[i] = SCM_MAKINUM (offset); + break; + } + } + return code; +} +#undef FUNC_NAME + + +/* + * Program + */ + +static long scm_program_tag; + +static SCM +make_program (SCM bytecode, SCM parent) +{ + SCM env = SCM_PROGRAM_P (parent) ? SCM_PROGRAM_ENV (parent) : SCM_BOOL_F; + int nexts = SCM_BYTECODE_NEXTS (bytecode); + + if (nexts) + { + SCM tmp = SCM_VM_MAKE_EXTERNAL (nexts); + SCM_VM_EXTERNAL_LINK (tmp) = env; + env = tmp; + } + + SCM_RETURN_NEWSMOB2 (scm_program_tag, + SCM_UNPACK (bytecode), + SCM_UNPACK (env)); +} + +static SCM +mark_program (SCM program) +{ + scm_gc_mark (SCM_PROGRAM_CODE (program)); + return SCM_PROGRAM_ENV (program); +} + +static SCM scm_program_name (SCM program); + +static int +print_program (SCM obj, SCM port, scm_print_state *pstate) +{ + SCM name = scm_program_name (obj); + scm_puts ("#', port); + return 1; +} + +static void +init_program_type () +{ + scm_program_tag = scm_make_smob_type ("program", 0); + scm_set_smob_mark (scm_program_tag, mark_program); + scm_set_smob_print (scm_program_tag, print_program); +} + +/* 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_make_program, "make-program", 2, 0, 0, + (SCM bytecode, SCM parent), +"") +#define FUNC_NAME s_scm_make_program +{ + SCM_VALIDATE_BYTECODE (1, bytecode); + return make_program (bytecode, parent); +} +#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_object_property (program, scm_sym_name); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0, + (SCM program), +"") +#define FUNC_NAME s_scm_program_code +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_CODE (program); +} +#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_VM_MAKE_ADDRESS (SCM_PROGRAM_BASE (program)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0, + (SCM program), +"") +#define FUNC_NAME s_scm_program_external +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_ENV (program); +} +#undef FUNC_NAME + + +/* + * VM Frame + */ + +static long scm_vm_frame_tag; + +/* This is used for debugging */ +struct scm_vm_frame { + int size; + SCM program; + SCM variables; + SCM dynamic_link; + SCM stack_pointer; + SCM return_address; +}; + +#define SCM_VM_FRAME_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_frame_tag, OBJ) +#define SCM_VM_FRAME_DATA(FR) ((struct scm_vm_frame *) SCM_SMOB_DATA (FR)) +#define SCM_VALIDATE_VM_FRAME(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_FRAME_P) + +static SCM +make_vm_frame (SCM *fp) +{ + int i; + int size = SCM_INUM (SCM_VM_FRAME_SIZE (fp)); + struct scm_vm_frame *p = scm_must_malloc (sizeof (*p), "make_vm_frame"); + p->program = SCM_VM_FRAME_PROGRAM (fp); + p->dynamic_link = SCM_VM_FRAME_DYNAMIC_LINK (fp); + p->stack_pointer = SCM_VM_FRAME_STACK_POINTER (fp); + p->return_address = SCM_VM_FRAME_RETURN_ADDRESS (fp); + + if (!SCM_FALSEP (p->dynamic_link)) + p->dynamic_link = make_vm_frame (SCM_VM_ADDRESS (p->dynamic_link)); + + size += SCM_PROGRAM_NREQS (p->program) + SCM_PROGRAM_RESTP (p->program); + p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); + for (i = 0; i < size; i++) + SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i); + + SCM_RETURN_NEWSMOB (scm_vm_frame_tag, p); +} + +static SCM +mark_vm_frame (SCM frame) +{ + struct scm_vm_frame *p = SCM_VM_FRAME_DATA (frame); + scm_gc_mark (p->program); + scm_gc_mark (p->dynamic_link); + return p->variables; +} + +static void +init_vm_frame_type () +{ + scm_vm_frame_tag = scm_make_smob_type ("vm-frame", 0); + scm_set_smob_mark (scm_vm_frame_tag, mark_vm_frame); +} + +/* Scheme interface */ + +SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_frame_p +{ + return SCM_BOOL (SCM_VM_FRAME_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_program +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->program; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_variables +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->variables; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_dynamic_link +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->dynamic_link; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_stack_pointer +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->stack_pointer; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_return_address +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->return_address; +} +#undef FUNC_NAME + + +/* + * VM Continuation + */ + +static long scm_vm_cont_tag; + +static SCM +capture_vm_cont (struct scm_vm *vmp) +{ + struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont"); + p->stack_size = vmp->stack_limit - vmp->sp; + p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM), + "capture_vm_cont"); + p->stack_limit = p->stack_base + p->stack_size - 1; + p->pc = vmp->pc; + p->sp = (SCM *) (vmp->stack_limit - vmp->sp); + p->fp = (SCM *) (vmp->stack_limit - vmp->fp); + memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM)); + SCM_RETURN_NEWSMOB (scm_vm_cont_tag, p); +} + +static void +reinstate_vm_cont (struct scm_vm *vmp, SCM cont) +{ + struct scm_vm *p = SCM_VM_CONT_VMP (cont); + if (vmp->stack_size < p->stack_size) + { + puts ("FIXME: Need to expand"); + abort (); + } + vmp->pc = p->pc; + vmp->sp = vmp->stack_limit - (int) p->sp; + vmp->fp = vmp->stack_limit - (int) p->fp; + memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM)); +} + +static SCM +mark_vm_cont (SCM cont) +{ + SCM *p; + struct scm_vm *vmp = SCM_VM_CONT_VMP (cont); + for (p = vmp->stack_base; p <= vmp->stack_limit; p++) + if (SCM_NIMP (*p)) + scm_gc_mark (*p); + return SCM_BOOL_F; +} + +static scm_sizet +free_vm_cont (SCM cont) +{ + struct scm_vm *p = SCM_VM_CONT_VMP (cont); + int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM); + scm_must_free (p->stack_base); + scm_must_free (p); + return size; +} + +static void +init_vm_cont_type () +{ + scm_vm_cont_tag = scm_make_smob_type ("vm-cont", 0); + scm_set_smob_mark (scm_vm_cont_tag, mark_vm_cont); + scm_set_smob_free (scm_vm_cont_tag, free_vm_cont); +} + + +/* + * VM + */ + +static long scm_vm_tag; + +static SCM +make_vm (int stack_size) +{ + struct scm_vm *vmp = scm_must_malloc (sizeof (struct scm_vm), "make_vm"); + vmp->stack_size = stack_size; + vmp->stack_base = scm_must_malloc (stack_size * sizeof (SCM), "make_vm"); + vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1; + vmp->sp = vmp->stack_limit; + vmp->ac = SCM_BOOL_F; + vmp->pc = NULL; + vmp->fp = NULL; + vmp->options = SCM_EOL; + vmp->boot_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->halt_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->next_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->call_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->apply_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->return_hook = scm_make_hook (SCM_MAKINUM (1)); + SCM_RETURN_NEWSMOB (scm_vm_tag, vmp); +} + +static SCM +mark_vm (SCM vm) +{ + SCM *p; + struct scm_vm *vmp = SCM_VM_DATA (vm); + for (p = vmp->sp + 1; p <= vmp->stack_limit; p++) + if (SCM_NIMP (*p)) + scm_gc_mark (*p); + + scm_gc_mark (vmp->ac); + scm_gc_mark (vmp->boot_hook); + scm_gc_mark (vmp->halt_hook); + scm_gc_mark (vmp->next_hook); + scm_gc_mark (vmp->call_hook); + scm_gc_mark (vmp->apply_hook); + scm_gc_mark (vmp->return_hook); + return vmp->options; +} + +static void +init_vm_type () +{ + scm_vm_tag = scm_make_smob_type ("vm", sizeof (struct scm_vm)); + scm_set_smob_mark (scm_vm_tag, mark_vm); +} + +/* Scheme interface */ + +SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_vm_version +{ + return scm_makfrom0str (VERSION); +} +#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, + (), +"") +#define FUNC_NAME s_scm_make_vm +{ + return make_vm (VM_DEFAULT_STACK_SIZE); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_ac, "vm:ac", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_ac +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->ac; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_pc, "vm:pc", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_pc +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->pc); +} +#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_VM_MAKE_ADDRESS (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_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->fp); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_current_frame +{ + SCM_VALIDATE_VM (1, vm); + return make_vm_frame (SCM_VM_DATA (vm)->fp); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 2, 0, 0, + (SCM vm, SCM addr), +"") +#define FUNC_NAME s_scm_vm_fetch_code +{ + SCM *p, list; + struct scm_instruction *inst; + + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_INUM (2, addr); + + p = SCM_VM_ADDRESS (addr); + + inst = find_instruction_by_code (*p); + if (!inst) + SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr)); + + list = SCM_LIST1 (scm_instruction_name (inst->obj)); + if (inst->type != INST_NONE) + { + if (inst->type == INST_ADDR) + { + p = SCM_CODE_TO_ADDR (p[1]); + SCM_SETCDR (list, SCM_LIST1 (SCM_VM_MAKE_ADDRESS (p))); + } + else + SCM_SETCDR (list, SCM_LIST1 (p[1])); + } + return list; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_stack_to_list, "vm-stack->list", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_stack_to_list +{ + struct scm_vm *vmp; + SCM *p, list = SCM_EOL; + + SCM_VALIDATE_VM (1, vm); + + vmp = SCM_VM_DATA (vm); + for (p = vmp->sp + 1; p <= vmp->stack_limit; p++) + list = scm_cons (*p, list); + return list; +} +#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); + SCM_VALIDATE_SYMBOL (2, key); + return scm_assq_ref (SCM_VM_DATA (vm)->options, key); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_set_option_x, "vm-set-option!", 3, 0, 0, + (SCM vm, SCM key, SCM val), +"") +#define FUNC_NAME s_scm_vm_set_option_x +{ + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_SYMBOL (2, key); + 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_boot_hook, "vm-boot-hook", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_boot_hook +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (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 +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (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 +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->next_hook; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_call_hook, "vm-call-hook", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_call_hook +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->call_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 +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->apply_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 +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->return_hook; +} +#undef FUNC_NAME + +SCM_SYMBOL (sym_debug, "debug"); + +static SCM scm_regular_vm (SCM vm, SCM program); +static SCM scm_debug_vm (SCM vm, SCM program); + +#define VM_CODE(name) SCM_ADDR_TO_CODE (find_instruction_by_name (name)->addr) + +SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0, + (SCM vm, SCM program), +"") +#define FUNC_NAME s_scm_vm_run +{ + SCM bootcode; + static SCM template[5]; + + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_PROGRAM (2, program); + + if (SCM_EQ_P (template[0], SCM_PACK (0))) + { + template[0] = VM_CODE ("%loadc"); + template[1] = SCM_BOOL_F; + template[2] = VM_CODE ("%call"); + template[3] = SCM_MAKINUM (0); + template[4] = VM_CODE ("%halt"); + } + + /* Create a boot program */ + bootcode = make_bytecode (5); + memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 5); + SCM_BYTECODE_BASE (bootcode)[1] = program; + SCM_BYTECODE_SIZE (bootcode) = 5; + SCM_BYTECODE_EXTS (bootcode) = NULL; + SCM_BYTECODE_NREQS (bootcode) = 0; + SCM_BYTECODE_RESTP (bootcode) = 0; + SCM_BYTECODE_NVARS (bootcode) = 0; + SCM_BYTECODE_NEXTS (bootcode) = 0; + program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F); + + if (SCM_FALSEP (scm_vm_option (vm, sym_debug))) + return scm_regular_vm (vm, program); + else + return scm_debug_vm (vm, program); +} +#undef FUNC_NAME + + +/* + * The VM engines + */ + +/* We don't want to snarf the engines */ +#ifndef SCM_MAGIC_SNARFER + +/* the regular engine */ +#define VM_ENGINE SCM_VM_REGULAR_ENGINE +#include "vm_engine.c" +#undef VM_ENGINE + +/* the debug engine */ +#define VM_ENGINE SCM_VM_DEBUG_ENGINE +#include "vm_engine.c" +#undef VM_ENGINE + +#endif /* not SCM_MAGIC_SNARFER */ + + +/* + * Initialize + */ + +static SCM scm_module_vm; + +void +scm_init_vm () +{ + SCM old_module; + + /* Initialize the module */ + scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)")); + old_module = scm_select_module (scm_module_vm); + + init_instruction_type (); + init_bytecode_type (); + init_program_type (); + init_vm_frame_type (); + init_vm_cont_type (); + init_vm_type (); + +#include "vm.x" + + scm_select_module (old_module); + + /* Initialize instruction tables */ + { + int i; + struct scm_instruction *p; + + SCM vm = make_vm (0); + scm_regular_vm (vm, SCM_BOOL_F); + scm_debug_vm (vm, SCM_BOOL_F); + + /* hash table */ + for (i = 0; i < INSTRUCTION_HASH_SIZE; i++) + scm_instruction_hash_table[i] = NULL; + + for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + { + int hash; + struct inst_hash *data; + SCM inst = scm_permanent_object (make_instruction (p)); + p->obj = inst; + if (p->restp) p->type = INST_INUM; + hash = INSTRUCTION_HASH (p->addr); + data = scm_must_malloc (sizeof (*data), "inst_hash"); + data->addr = p->addr; + data->inst = p; + data->next = scm_instruction_hash_table[hash]; + scm_instruction_hash_table[hash] = data; + } + } +} + +void +scm_init_vm_vm_module () +{ + scm_register_module_xxx ("vm vm", (void *) scm_init_vm); +} diff --git a/src/vm.h b/src/vm.h new file mode 100644 index 000000000..dc493bf5d --- /dev/null +++ b/src/vm.h @@ -0,0 +1,226 @@ +/* Copyright (C) 2000 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_H +#define VM_H + +#include + + +/* + * Instruction + */ + +/* Opcode */ +enum scm_opcode { +#include "vm_system.op" +#include "vm_scheme.op" +#include "vm_number.op" + op_last +}; + +/* Argument type */ +/* Modify `mark_bytecode', `scm_make_bytecode', and `scm_bytecode_decode'! */ +enum scm_inst_type { + INST_NONE, /* no argument */ + INST_INUM, /* fixed integer */ + INST_SCM, /* scheme object */ + INST_EXT, /* external offset */ + INST_TOP, /* top-level variable */ + INST_CODE, /* program code */ + INST_ADDR /* program address */ +}; + +struct scm_instruction { + enum scm_opcode opcode; /* opcode */ + enum scm_inst_type type; /* argument type */ + char *name; /* instruction name */ + void *addr; /* instruction address */ + SCM obj; /* instruction object */ + /* fields for VM functions */ + char *sname; /* Scheme procedure name */ + char nargs; /* the number of arguments */ + char restp; /* have a rest argument or not */ +}; + +#define SCM_INSTRUCTION_P(OBJ) SCM_SMOB_PREDICATE (scm_instruction_tag, OBJ) +#define SCM_INSTRUCTION_DATA(INST) ((struct scm_instruction *) SCM_SMOB_DATA (INST)) +#define SCM_VALIDATE_INSTRUCTION(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, INSTRUCTION_P) + +#define SCM_SYSTEM_INSTRUCTION_P(OBJ) \ + (SCM_INSTRUCTION_P (OBJ) && !SCM_INSTRUCTION_DATA(OBJ)->sname) +#define SCM_FUNCTIONAL_INSTRUCTION_P(OBJ) \ + (SCM_INSTRUCTION_P (OBJ) && SCM_INSTRUCTION_DATA(OBJ)->sname) + +#define SCM_ADDR_TO_CODE(ADDR) SCM_PACK (ADDR) +#define SCM_CODE_TO_ADDR(CODE) ((void *) SCM_UNPACK (CODE)) +#define SCM_CODE_TO_DEBUG_ADDR(CODE) instruction_code_to_debug_addr (CODE) + + +/* + * Bytecode + */ + +struct scm_bytecode { + int size; /* the size of the bytecode */ + char nreqs; /* the number of required arguments */ + char restp; /* have a rest argument or not */ + char nvars; /* the number of local variables */ + char nexts; /* the number of external variables */ + int *exts; /* externalized arguments */ + SCM base[0]; /* base address (must be the last!) */ +}; + +#define SCM_BYTECODE_P(OBJ) SCM_SMOB_PREDICATE (scm_bytecode_tag, OBJ) +#define SCM_BYTECODE_DATA(BC) ((struct scm_bytecode *) SCM_SMOB_DATA (BC)) +#define SCM_VALIDATE_BYTECODE(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, BYTECODE_P) + +#define SCM_BYTECODE_SIZE(BC) SCM_BYTECODE_DATA (BC)->size +#define SCM_BYTECODE_NREQS(BC) SCM_BYTECODE_DATA (BC)->nreqs +#define SCM_BYTECODE_RESTP(BC) SCM_BYTECODE_DATA (BC)->restp +#define SCM_BYTECODE_NVARS(BC) SCM_BYTECODE_DATA (BC)->nvars +#define SCM_BYTECODE_NEXTS(BC) SCM_BYTECODE_DATA (BC)->nexts +#define SCM_BYTECODE_EXTS(BC) SCM_BYTECODE_DATA (BC)->exts +#define SCM_BYTECODE_BASE(BC) SCM_BYTECODE_DATA (BC)->base + +extern SCM scm_bytecode_p (SCM obj); +extern SCM scm_make_bytecode (SCM code); +extern SCM scm_bytecode_decode (SCM bytecode); + + +/* + * Program + */ + +#define SCM_MAKE_PROGRAM(CODE,ENV) make_program (CODE, ENV) +#define SCM_PROGRAM_P(OBJ) SCM_SMOB_PREDICATE (scm_program_tag, OBJ) +#define SCM_PROGRAM_CODE(PROG) SCM_CELL_OBJECT_1 (PROG) +#define SCM_PROGRAM_ENV(PROG) SCM_CELL_OBJECT_2 (PROG) +#define SCM_VALIDATE_PROGRAM(POS,PROG) SCM_MAKE_VALIDATE (POS, PROG, PROGRAM_P) + +/* Abbreviations */ +#define SCM_PROGRAM_SIZE(PROG) SCM_BYTECODE_SIZE (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_NREQS(PROG) SCM_BYTECODE_NREQS (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_RESTP(PROG) SCM_BYTECODE_RESTP (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_NVARS(PROG) SCM_BYTECODE_NVARS (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_NEXTS(PROG) SCM_BYTECODE_NEXTS (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_EXTS(PROG) SCM_BYTECODE_EXTS (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_BASE(PROG) SCM_BYTECODE_BASE (SCM_PROGRAM_CODE (PROG)) + +extern SCM scm_program_p (SCM obj); +extern SCM scm_make_program (SCM bytecode, SCM env); +extern SCM scm_program_code (SCM program); +extern SCM scm_program_base (SCM program); + + +/* + * VM Address + */ + +#define SCM_VM_MAKE_ADDRESS(ADDR) SCM_MAKINUM ((long) (ADDR)) +#define SCM_VM_ADDRESS(OBJ) ((SCM *) SCM_INUM (OBJ)) + + +/* + * VM External + */ + +/* VM external maintains a set of variables outside of the stack. + This is used to implement external chain of the environment. */ + +#define SCM_VM_MAKE_EXTERNAL(SIZE) scm_make_vector (SCM_MAKINUM ((SIZE) + 1), SCM_UNDEFINED) +#define SCM_VM_EXTERNAL_LINK(EXT) (SCM_VELTS (EXT)[0]) +#define SCM_VM_EXTERNAL_VARIABLE(EXT,N) (SCM_VELTS (EXT)[(N) + 1]) + + +/* + * VM Continuation + */ + +#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_cont_tag, OBJ) +#define SCM_VM_CONT_VMP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT)) + +#define SCM_VM_CAPTURE_CONT(VMP) capture_vm_cont (VMP) +#define SCM_VM_REINSTATE_CONT(VMP,CONT) reinstate_vm_cont (VMP, CONT) + + +/* + * VM Frame + */ + +/* VM frame is allocated in the stack */ +/* NOTE: Modify make_vm_frame and VM_NEW_FRAME too! */ +#define SCM_VM_FRAME_DATA_SIZE 5 +#define SCM_VM_FRAME_VARIABLE(FP,N) (FP[N]) +#define SCM_VM_FRAME_SIZE(FP) (FP[-1]) +#define SCM_VM_FRAME_PROGRAM(FP) (FP[-2]) +#define SCM_VM_FRAME_DYNAMIC_LINK(FP) (FP[-3]) +#define SCM_VM_FRAME_STACK_POINTER(FP) (FP[-4]) +#define SCM_VM_FRAME_RETURN_ADDRESS(FP) (FP[-5]) + + +/* + * VM + */ + +/* Modify make_vm, mark_vm, and SYNC, too! */ +struct scm_vm { + SCM ac; /* Accumulator */ + SCM *pc; /* Program counter */ + SCM *sp; /* Stack pointer */ + SCM *fp; /* Frame pointer */ + int stack_size; + SCM *stack_base; + SCM *stack_limit; + SCM options; + SCM boot_hook, halt_hook, next_hook; + SCM call_hook, apply_hook, return_hook; +}; + +#define SCM_VM_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_tag, OBJ) +#define SCM_VM_DATA(VM) ((struct scm_vm *) SCM_SMOB_DATA (VM)) +#define SCM_VALIDATE_VM(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_P) + +/* Engine types */ +#define SCM_VM_REGULAR_ENGINE 0 /* Fail safe and fast enough */ +#define SCM_VM_DEBUG_ENGINE 1 /* Functional but very slow */ + +#endif /* not VM_H */ diff --git a/src/vm_engine.c b/src/vm_engine.c new file mode 100644 index 000000000..2c6a1851c --- /dev/null +++ b/src/vm_engine.c @@ -0,0 +1,132 @@ +/* Copyright (C) 2000 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 two times! */ + +#include "vm_engine.h" + +/* VM names */ +#undef VM_NAME +#undef VM_TABLE +#if VM_ENGINE == SCM_VM_REGULAR_ENGINE +#define VM_NAME scm_regular_vm +#define VM_TABLE scm_regular_instruction_table +#else +#if VM_ENGINE == SCM_VM_DEBUG_ENGINE +#define VM_NAME scm_debug_vm +#define VM_TABLE scm_debug_instruction_table +#endif +#endif + +static SCM +VM_NAME (SCM vm, SCM program) +#define FUNC_NAME "vm-engine" +{ + /* Copies of VM registers */ + SCM ac = SCM_PACK (0); + SCM *pc = NULL; + SCM *sp = NULL; + SCM *fp = NULL; + + /* Stack boundaries */ + SCM *stack_base = NULL; + SCM *stack_limit = NULL; + + /* Function arguments */ + int an = 0; + SCM a2 = SCM_PACK (0); + SCM a3 = SCM_PACK (0); + + /* Miscellaneous variables */ + SCM dynwinds = SCM_EOL; + struct scm_vm *vmp = NULL; + +#if VM_USE_HOOK + SCM hook_args = SCM_LIST1 (vm); +#endif + + /* Initialize the instruction table at the first time. + * This code must be here because the following table contains + * pointers to the labels defined in this function. */ + if (!VM_TABLE) + { + static struct scm_instruction table[] = { +#include "vm_system.vi" +#include "vm_scheme.vi" +#include "vm_number.vi" + { op_last } + }; + VM_TABLE = table; + return SCM_UNSPECIFIED; + } + + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_PROGRAM (2, program); + + /* Initialize the VM */ + vmp = SCM_VM_DATA (vm); + vmp->pc = SCM_PROGRAM_BASE (program); + vmp->sp = vmp->stack_limit; + LOAD (); + + /* top frame */ + VM_NEW_FRAME (fp, program, SCM_BOOL_F, + SCM_VM_MAKE_ADDRESS (0), + SCM_VM_MAKE_ADDRESS (0)); + + /* Let's go! */ + VM_BOOT_HOOK (); + +#ifndef HAVE_LABELS_AS_VALUES + vm_start: switch (*pc++) { +#endif + +#include "vm_system.c" +#include "vm_scheme.c" +#include "vm_number.c" + +#ifndef HAVE_LABELS_AS_VALUES + } +#endif + + abort (); /* never reached */ +} +#undef FUNC_NAME diff --git a/src/vm_engine.h b/src/vm_engine.h new file mode 100644 index 000000000..19493b301 --- /dev/null +++ b/src/vm_engine.h @@ -0,0 +1,345 @@ +/* Copyright (C) 2000 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* This file is included in vm_engine.c */ + +/* + * VM Options + */ + +#undef VM_USE_BOOT_HOOK +#undef VM_USE_HALT_HOOK +#undef VM_USE_NEXT_HOOK +#undef VM_USE_CALL_HOOK +#undef VM_USE_APPLY_HOOK +#undef VM_USE_RETURN_HOOK +#undef VM_INIT_LOCAL_VARIABLES +#undef VM_CHECK_LINK +#undef VM_CHECK_BINDING +#undef VM_CHECK_PROGRAM_COUNTER + +#if VM_ENGINE == SCM_VM_REGULAR_ENGINE +#define VM_USE_BOOT_HOOK 0 +#define VM_USE_HALT_HOOK 0 +#define VM_USE_NEXT_HOOK 0 +#define VM_USE_CALL_HOOK 0 +#define VM_USE_APPLY_HOOK 0 +#define VM_USE_RETURN_HOOK 0 +#define VM_INIT_LOCAL_VARIABLES 0 +#define VM_CHECK_LINK 0 +#define VM_CHECK_BINDING 1 +#define VM_CHECK_PROGRAM_COUNTER 0 +#else +#if VM_ENGINE == SCM_VM_DEBUG_ENGINE +#define VM_USE_BOOT_HOOK 1 +#define VM_USE_HALT_HOOK 1 +#define VM_USE_NEXT_HOOK 1 +#define VM_USE_CALL_HOOK 1 +#define VM_USE_APPLY_HOOK 1 +#define VM_USE_RETURN_HOOK 1 +#define VM_INIT_LOCAL_VARIABLES 1 +#define VM_CHECK_LINK 1 +#define VM_CHECK_BINDING 1 +#define VM_CHECK_PROGRAM_COUNTER 1 +#endif +#endif + +#undef VM_USE_HOOK +#if VM_USE_BOOT_HOOK || VM_USE_HALT_HOOK || VM_USE_NEXT_HOOK \ + || VM_USE_CALL_HOOK || VM_USE_APPLY_HOOK || VM_USE_RETURN_HOOK +#define VM_USE_HOOK 1 +#else +#define VM_USE_HOOK 0 +#endif + + +/* + * Type checking + */ + +#define VM_ASSERT_PROGRAM(OBJ) SCM_VALIDATE_PROGRAM (1, OBJ) + +#undef VM_ASSERT_BOUND +#if VM_CHECK_BINDING +#define VM_ASSERT_BOUND(CELL) \ + if (SCM_UNBNDP (SCM_CDR (CELL))) \ + SCM_MISC_ERROR ("Unbound variable: ~S", SCM_LIST1 (SCM_CAR (CELL))) +#else +#define VM_ASSERT_BOUND(CELL) +#endif + +#undef VM_ASSERT_LINK +#if VM_CHECK_LINK +#define VM_ASSERT_LINK(OBJ) \ + if (SCM_FALSEP (OBJ)) \ + SCM_MISC_ERROR ("VM broken link", SCM_EOL) +#else +#define VM_ASSERT_LINK(OBJ) +#endif + + +/* + * Hooks + */ + +#undef VM_BOOT_HOOK +#if VM_USE_BOOT_HOOK +#define VM_BOOT_HOOK() SYNC (); scm_c_run_hook (vmp->boot_hook, hook_args) +#else +#define VM_BOOT_HOOK() +#endif + +#undef VM_HALT_HOOK +#if VM_USE_HALT_HOOK +#define VM_HALT_HOOK() SYNC (); scm_c_run_hook (vmp->halt_hook, hook_args) +#else +#define VM_HALT_HOOK() +#endif + +#undef VM_NEXT_HOOK +#if VM_USE_NEXT_HOOK +#define VM_NEXT_HOOK() SYNC (); scm_c_run_hook (vmp->next_hook, hook_args) +#else +#define VM_NEXT_HOOK() +#endif + +#undef VM_CALL_HOOK +#if VM_USE_CALL_HOOK +#define VM_CALL_HOOK() SYNC (); scm_c_run_hook (vmp->call_hook, hook_args) +#else +#define VM_CALL_HOOK() +#endif + +#undef VM_APPLY_HOOK +#if VM_USE_APPLY_HOOK +#define VM_APPLY_HOOK() SYNC (); scm_c_run_hook (vmp->apply_hook, hook_args) +#else +#define VM_APPLY_HOOK() +#endif + +#undef VM_RETURN_HOOK +#if VM_USE_RETURN_HOOK +#define VM_RETURN_HOOK() SYNC (); scm_c_run_hook (vmp->return_hook, hook_args) +#else +#define VM_RETURN_HOOK() +#endif + + +/* + * Basic operations + */ + +#define LOAD() \ +{ \ + ac = vmp->ac; \ + pc = vmp->pc; \ + sp = vmp->sp; \ + fp = vmp->fp; \ + stack_base = vmp->stack_base; \ + stack_limit = vmp->stack_limit; \ +} + +#define SYNC() \ +{ \ + vmp->ac = ac; \ + vmp->pc = pc; \ + vmp->sp = sp; \ + vmp->fp = fp; \ +} + +#define FETCH() *pc++ + +#define CONS(X,Y,Z) \ +{ \ + SCM cell; \ + SYNC (); \ + SCM_NEWCELL (cell); \ + SCM_SET_CELL_OBJECT_0 (cell, Y); \ + SCM_SET_CELL_OBJECT_1 (cell, Z); \ + X = cell; \ +} + +#define VM_SETUP_ARGS2() an = 2; a2 = ac; POP (ac); +#define VM_SETUP_ARGS3() an = 3; a3 = ac; POP (a2); POP (ac); +#define VM_SETUP_ARGS4() an = 4; a4 = ac; POP (a3); POP (a2); POP (ac); +#define VM_SETUP_ARGSN() an = SCM_INUM (FETCH ()); + + +/* + * Stack operation + */ + +#define PUSH(X) \ +{ \ + if (sp < stack_base) \ + SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \ + *sp-- = (X); \ +} + +#define POP(X) \ +{ \ + if (sp == stack_limit) \ + SCM_MISC_ERROR ("FIXME: Stack underflow", SCM_EOL); \ + (X) = *++sp; \ +} + +#define POP_LIST(N,L) \ +{ \ + while (N-- > 0) \ + { \ + SCM obj; \ + POP (obj); \ + CONS (L, obj, L); \ + } \ +} + + +/* + * Frame allocation + */ + +/* an = the number of arguments */ +#define VM_SETUP_ARGS(PROG,NREQS,RESTP) \ +{ \ + if (RESTP) \ + /* have a rest argument */ \ + { \ + SCM list; \ + if (an < NREQS) \ + scm_wrong_num_args (PROG); \ + \ + /* Construct the rest argument list */ \ + an -= NREQS; /* the number of rest arguments */ \ + list = SCM_EOL; /* list of the rest arguments */ \ + POP_LIST (an, list); \ + PUSH (list); \ + } \ + else \ + /* not have a rest argument */ \ + { \ + if (an != NREQS) \ + scm_wrong_num_args (PROG); \ + } \ +} + +#define VM_EXPORT_ARGS(FP,PROG) \ +{ \ + int *exts = SCM_PROGRAM_EXTS (PROG); \ + if (exts) \ + { \ + int n = exts[0]; \ + while (n-- > 0) \ + SCM_VM_EXTERNAL_VARIABLE (SCM_PROGRAM_ENV (PROG), n) \ + = SCM_VM_FRAME_VARIABLE (FP, exts[n + 1]); \ + } \ +} + +#undef VM_FRAME_INIT_VARIABLES +#if VM_INIT_LOCAL_VARIABLES +/* This is necessary when creating frame objects for debugging */ +#define VM_FRAME_INIT_VARIABLES(FP,NVARS) \ +{ \ + int i; \ + for (i = 0; i < NVARS; i++) \ + SCM_VM_FRAME_VARIABLE (FP, i) = SCM_UNDEFINED; \ +} +#else +#define VM_FRAME_INIT_VARIABLES(FP,NVARS) +#endif + +#define VM_NEW_FRAME(FP,PROG,DL,SP,RA) \ +{ \ + int nvars = SCM_PROGRAM_NVARS (PROG); /* the number of local vars */ \ + int nreqs = SCM_PROGRAM_NREQS (PROG); /* the number of required args */ \ + int restp = SCM_PROGRAM_RESTP (PROG); /* have a rest argument or not */ \ + \ + VM_SETUP_ARGS (PROG, nreqs, restp); \ + if (sp - nvars - SCM_VM_FRAME_DATA_SIZE < stack_base - 1) \ + SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \ + sp -= nvars + SCM_VM_FRAME_DATA_SIZE; \ + FP = sp + SCM_VM_FRAME_DATA_SIZE + 1; \ + SCM_VM_FRAME_SIZE (FP) = SCM_MAKINUM (nvars); \ + SCM_VM_FRAME_PROGRAM (FP) = PROG; \ + SCM_VM_FRAME_DYNAMIC_LINK (FP) = DL; \ + SCM_VM_FRAME_STACK_POINTER (FP) = SP; \ + SCM_VM_FRAME_RETURN_ADDRESS (FP) = RA; \ + VM_FRAME_INIT_VARIABLES (FP, nvars); \ + VM_EXPORT_ARGS (FP, PROG); \ +} + + +/* + * Goto next + */ + +#undef VM_PROGRAM_COUNTER_CHECK +#if VM_CHECK_PROGRAM_COUNTER +#define VM_PROGRAM_COUNTER_CHECK() \ +{ \ + SCM prog = SCM_VM_FRAME_PROGRAM (fp); \ + if (pc < SCM_PROGRAM_BASE (prog) \ + || pc >= (SCM_PROGRAM_BASE (prog) + SCM_PROGRAM_SIZE (prog))) \ + SCM_MISC_ERROR ("VM accessed invalid program address", SCM_EOL); \ +} +#else +#define VM_PROGRAM_COUNTER_CHECK() +#endif + +#undef VM_GOTO_NEXT +#if HAVE_LABELS_AS_VALUES +#if VM_ENGINE == SCM_VM_DEBUG_ENGINE +#define VM_GOTO_NEXT() goto *SCM_CODE_TO_DEBUG_ADDR (FETCH ()) +#else /* not SCM_VM_DEBUG_ENGINE */ +#define VM_GOTO_NEXT() goto *SCM_CODE_TO_ADDR (FETCH ()) +#endif +#else /* not HAVE_LABELS_AS_VALUES */ +#define VM_GOTO_NEXT() goto vm_start +#endif + +#define NEXT \ +{ \ + VM_PROGRAM_COUNTER_CHECK (); \ + VM_NEXT_HOOK (); \ + VM_GOTO_NEXT (); \ +} + +/* Just an abbreviation */ +#define RETURN(X) { ac = (X); NEXT; } diff --git a/src/vm_number.c b/src/vm_number.c new file mode 100644 index 000000000..7bf709215 --- /dev/null +++ b/src/vm_number.c @@ -0,0 +1,188 @@ +/* Copyright (C) 2000 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 */ + +#include "vm-snarf.h" + +SCM_DEFINE_VM_FUNCTION (zero_p, "zero?", "zero?", 1, 0) +{ + if (SCM_INUMP (ac)) + RETURN (SCM_BOOL (SCM_EQ_P (ac, SCM_INUM0))); + RETURN (scm_zero_p (ac)); +} + +SCM_DEFINE_VM_FUNCTION (inc, "1+", "inc", 1, 0) +{ + if (SCM_INUMP (ac)) + { + int n = SCM_INUM (ac) + 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_sum (ac, SCM_MAKINUM (1))); +} + +SCM_DEFINE_VM_FUNCTION (dec, "1-", "dec", 1, 0) +{ + if (SCM_INUMP (ac)) + { + int n = SCM_INUM (ac) - 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_difference (ac, SCM_MAKINUM (1))); +} + +SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_MAKINUM (0); + while (an-- > 0) + { + POP (a2); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (ac) + SCM_INUM (a2); + if (SCM_FIXABLE (n)) + { + ac = SCM_MAKINUM (n); + continue; + } + } + ac = scm_sum (ac, a2); + } + NEXT; +} + +SCM_DEFINE_VM_FUNCTION (add2, "+", "add2", 2, 0) +{ + VM_SETUP_ARGS2 (); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (ac) + SCM_INUM (a2); + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_sum (ac, a2)); +} + +SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_MAKINUM (0); + while (an-- > 1) + { + POP (a2); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (ac) + SCM_INUM (a2); + if (SCM_FIXABLE (n)) + { + ac = SCM_MAKINUM (n); + continue; + } + } + ac = scm_difference (ac, a2); + } + POP (a2); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (a2) - SCM_INUM (ac); + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_difference (a2, ac)); +} + +SCM_DEFINE_VM_FUNCTION (sub2, "-", "sub2", 2, 0) +{ + VM_SETUP_ARGS2 (); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (ac) - SCM_INUM (a2); + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_difference (ac, a2)); +} + +SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0) +{ + if (SCM_INUMP (ac)) + { + int n = - SCM_INUM (ac); + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_difference (ac, SCM_UNDEFINED)); +} + +#define REL2(CREL,SREL) \ + VM_SETUP_ARGS2 (); \ + if (SCM_INUMP (ac) && SCM_INUMP (a2)) \ + RETURN (SCM_BOOL (SCM_INUM (ac) CREL SCM_INUM (a2))); \ + RETURN (SREL (ac, a2)) + +SCM_DEFINE_VM_FUNCTION (lt2, "<", "lt2", 2, 0) +{ + REL2 (<, scm_less_p); +} + +SCM_DEFINE_VM_FUNCTION (gt2, ">", "gt2", 2, 0) +{ + REL2 (>, scm_gr_p); +} + +SCM_DEFINE_VM_FUNCTION (le2, "<=", "le2", 2, 0) +{ + REL2 (<=, scm_leq_p); +} + +SCM_DEFINE_VM_FUNCTION (ge2, ">=", "ge2", 2, 0) +{ + REL2 (>=, scm_geq_p); +} + +SCM_DEFINE_VM_FUNCTION (num_eq2, "=", "num-eq2", 2, 0) +{ + REL2 (==, scm_num_eq_p); +} diff --git a/src/vm_scheme.c b/src/vm_scheme.c new file mode 100644 index 000000000..cfccbeda2 --- /dev/null +++ b/src/vm_scheme.c @@ -0,0 +1,111 @@ +/* Copyright (C) 2000 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 */ + +#include "vm-snarf.h" + +SCM_DEFINE_VM_FUNCTION (null_p, "null?", "null?", 1, 0) +{ + RETURN (SCM_BOOL (SCM_NULLP (ac))); +} + +SCM_DEFINE_VM_FUNCTION (cons, "cons", "cons", 2, 0) +{ + VM_SETUP_ARGS2 (); + CONS (ac, ac, a2); + NEXT; +} + +SCM_DEFINE_VM_FUNCTION (list, "list", "list", 0, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_EOL; + POP_LIST (an, ac); + NEXT; +} + +SCM_DEFINE_VM_FUNCTION (car, "car", "car", 1, 0) +{ + SCM_VALIDATE_CONS (0, ac); + RETURN (SCM_CAR (ac)); +} + +SCM_DEFINE_VM_FUNCTION (cdr, "cdr", "cdr", 1, 0) +{ + SCM_VALIDATE_CONS (0, ac); + RETURN (SCM_CDR (ac)); +} + +SCM_DEFINE_VM_FUNCTION (not, "not", "not", 1, 0) +{ + RETURN (SCM_BOOL (SCM_FALSEP (ac))); +} + +SCM_DEFINE_VM_FUNCTION (append, "append", "append", 0, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_EOL; + POP_LIST (an, ac); + RETURN (scm_append (ac)); +} + +SCM_DEFINE_VM_FUNCTION (append_x, "append!", "append!", 0, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_EOL; + POP_LIST (an, ac); + RETURN (scm_append_x (ac)); +} + +SCM_DEFINE_VM_FUNCTION (catch, "catch", "catch", 3, 0) +{ + VM_SETUP_ARGS3 (); + dynwinds = SCM_EOL; +} + +SCM_DEFINE_VM_FUNCTION (call_cc, "call-with-current-continuation", "call/cc", 1, 0) +{ + SYNC (); /* must sync all registers */ + PUSH (SCM_VM_CAPTURE_CONT (vmp)); /* argument 1 */ + an = 1; /* the number of arguments */ + goto vm_call; +} diff --git a/src/vm_system.c b/src/vm_system.c new file mode 100644 index 000000000..f07e5af22 --- /dev/null +++ b/src/vm_system.c @@ -0,0 +1,549 @@ +/* Copyright (C) 2000 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 */ + +#include "vm-snarf.h" + +/* + * Variable access + */ + +#undef LOCAL_VAR +#define LOCAL_VAR(OFFSET) SCM_VM_FRAME_VARIABLE (fp, OFFSET) + +#undef EXTERNAL_FOCUS +#define EXTERNAL_FOCUS(DEPTH) \ +{ \ + int depth = DEPTH; \ + env = SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)); \ + while (depth-- > 0) \ + { \ + VM_ASSERT_LINK (env); \ + env = SCM_VM_EXTERNAL_LINK (env); \ + } \ +} + +#undef EXTERNAL_VAR +#define EXTERNAL_VAR(OFFSET) SCM_VM_EXTERNAL_VARIABLE (env, OFFSET) +#undef EXTERNAL_VAR0 +#define EXTERNAL_VAR0(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)), OFFSET) +#define EXTERNAL_VAR1(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp))), OFFSET) +#define EXTERNAL_VAR2(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_VM_EXTERNAL_LINK (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)))), OFFSET) + +#undef TOPLEVEL_VAR +#define TOPLEVEL_VAR(CELL) SCM_CDR (CELL) +#undef TOPLEVEL_VAR_SET +#define TOPLEVEL_VAR_SET(CELL,OBJ) SCM_SETCDR (CELL, OBJ) + + +/* + * Basic operations + */ + +/* Must be the first instruction! */ +SCM_DEFINE_INSTRUCTION (nop, "%nop", INST_NONE) +{ + NEXT; +} + +SCM_DEFINE_INSTRUCTION (halt, "%halt", INST_NONE) +{ + SYNC (); + VM_HALT_HOOK (); + return ac; +} + + +/* + * %push family + */ + +SCM_DEFINE_INSTRUCTION (push, "%push", INST_NONE) +{ + PUSH (ac); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushc, "%pushc", INST_SCM) +{ + PUSH (FETCH ()); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushl, "%pushl", INST_INUM) +{ + PUSH (LOCAL_VAR (SCM_INUM (FETCH ()))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushl_0, "%pushl:0", INST_NONE) +{ + PUSH (LOCAL_VAR (0)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushl_1, "%pushl:1", INST_NONE) +{ + PUSH (LOCAL_VAR (1)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe, "%pushe", INST_EXT) +{ + SCM env; + SCM loc = FETCH (); + EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); + PUSH (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc)))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_0, "%pushe:0", INST_INUM) +{ + PUSH (EXTERNAL_VAR0 (SCM_INUM (FETCH ()))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_0_0, "%pushe:0:0", INST_NONE) +{ + PUSH (EXTERNAL_VAR0 (0)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_0_1, "%pushe:0:1", INST_NONE) +{ + PUSH (EXTERNAL_VAR0 (1)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_1, "%pushe:1", INST_INUM) +{ + PUSH (EXTERNAL_VAR1 (SCM_INUM (FETCH ()))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_1_0, "%pushe:1:0", INST_NONE) +{ + PUSH (EXTERNAL_VAR1 (0)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_1_1, "%pushe:1:1", INST_NONE) +{ + PUSH (EXTERNAL_VAR1 (1)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_2, "%pushe:2", INST_INUM) +{ + PUSH (EXTERNAL_VAR2 (SCM_INUM (FETCH ()))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pusht, "%pusht", INST_TOP) +{ + ac = FETCH (); + VM_ASSERT_BOUND (ac); + PUSH (TOPLEVEL_VAR (ac)); + NEXT; +} + + +/* + * %load family + */ + +SCM_DEFINE_INSTRUCTION (load_unspecified, "%load-unspecified", INST_NONE) +{ + RETURN (SCM_UNSPECIFIED); +} + +SCM_DEFINE_INSTRUCTION (loadc, "%loadc", INST_SCM) +{ + RETURN (FETCH ()); +} + +SCM_DEFINE_INSTRUCTION (loadl, "%loadl", INST_INUM) +{ + RETURN (LOCAL_VAR (SCM_INUM (FETCH ()))); +} + +SCM_DEFINE_INSTRUCTION (loadl_0, "%loadl:0", INST_NONE) +{ + RETURN (LOCAL_VAR (0)); +} + +SCM_DEFINE_INSTRUCTION (loadl_1, "%loadl:1", INST_NONE) +{ + RETURN (LOCAL_VAR (1)); +} + +SCM_DEFINE_INSTRUCTION (loade, "%loade", INST_EXT) +{ + SCM env; + SCM loc = FETCH (); + EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); + RETURN (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc)))); +} + +SCM_DEFINE_INSTRUCTION (loade_0, "%loade:0", INST_INUM) +{ + RETURN (EXTERNAL_VAR0 (SCM_INUM (FETCH ()))); +} + +SCM_DEFINE_INSTRUCTION (loade_0_0, "%loade:0:0", INST_NONE) +{ + RETURN (EXTERNAL_VAR0 (0)); +} + +SCM_DEFINE_INSTRUCTION (loade_0_1, "%loade:0:1", INST_NONE) +{ + RETURN (EXTERNAL_VAR0 (1)); +} + +SCM_DEFINE_INSTRUCTION (loade_1, "%loade:1", INST_INUM) +{ + RETURN (EXTERNAL_VAR1 (SCM_INUM (FETCH ()))); +} + +SCM_DEFINE_INSTRUCTION (loade_1_0, "%loade:1:0", INST_NONE) +{ + RETURN (EXTERNAL_VAR1 (0)); +} + +SCM_DEFINE_INSTRUCTION (loade_1_1, "%loade:1:1", INST_NONE) +{ + RETURN (EXTERNAL_VAR1 (1)); +} + +SCM_DEFINE_INSTRUCTION (loade_2, "%loade:2", INST_INUM) +{ + RETURN (EXTERNAL_VAR2 (SCM_INUM (FETCH ()))); +} + +SCM_DEFINE_INSTRUCTION (loadt, "%loadt", INST_TOP) +{ + ac = FETCH (); + VM_ASSERT_BOUND (ac); + RETURN (TOPLEVEL_VAR (ac)); +} + + +/* + * %save family + */ + +SCM_DEFINE_INSTRUCTION (savel, "%savel", INST_INUM) +{ + LOCAL_VAR (SCM_INUM (FETCH ())) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savel_0, "%savel:0", INST_NONE) +{ + LOCAL_VAR (0) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savel_1, "%savel:1", INST_NONE) +{ + LOCAL_VAR (1) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee, "%savee", INST_EXT) +{ + SCM env; + SCM loc = FETCH (); + EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); + EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_0, "%savee:0", INST_INUM) +{ + EXTERNAL_VAR0 (SCM_INUM (FETCH ())) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_0_0, "%savee:0:0", INST_NONE) +{ + EXTERNAL_VAR0 (0) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_0_1, "%savee:0:1", INST_NONE) +{ + EXTERNAL_VAR0 (1) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_1, "%savee:1", INST_INUM) +{ + EXTERNAL_VAR1 (SCM_INUM (FETCH ())) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_1_0, "%savee:1:0", INST_NONE) +{ + EXTERNAL_VAR1 (0) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_1_1, "%savee:1:1", INST_NONE) +{ + EXTERNAL_VAR1 (1) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_2, "%savee:2", INST_INUM) +{ + EXTERNAL_VAR2 (SCM_INUM (FETCH ())) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP) +{ + SCM cell = FETCH (); + scm_set_object_property_x (ac, scm_sym_name, SCM_CAR (cell)); + TOPLEVEL_VAR_SET (cell, ac); + NEXT; +} + + +/* + * branch and jump + */ + +SCM_DEFINE_INSTRUCTION (br_if, "%br-if", INST_ADDR) +{ + SCM addr = FETCH (); /* must always fetch */ + if (!SCM_FALSEP (ac)) + pc = SCM_VM_ADDRESS (addr); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (br_if_not, "%br-if-not", INST_ADDR) +{ + SCM addr = FETCH (); /* must always fetch */ + if (SCM_FALSEP (ac)) + pc = SCM_VM_ADDRESS (addr); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (br_if_null, "%br-if-null", INST_ADDR) +{ + SCM addr = FETCH (); /* must always fetch */ + if (SCM_NULLP (ac)) + pc = SCM_VM_ADDRESS (addr); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (br_if_not_null, "%br-if-not-null", INST_ADDR) +{ + SCM addr = FETCH (); /* must always fetch */ + if (!SCM_NULLP (ac)) + pc = SCM_VM_ADDRESS (addr); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR) +{ + pc = SCM_VM_ADDRESS (*pc); + NEXT; +} + + +/* + * Subprogram call + */ + +SCM_DEFINE_INSTRUCTION (make_program, "%make-program", INST_CODE) +{ + SYNC (); /* must be called before GC */ + RETURN (SCM_MAKE_PROGRAM (FETCH (), SCM_VM_FRAME_PROGRAM (fp))); +} + +/* Before: + ac = program + pc[0] = the number of arguments + + After: + pc = program's address +*/ +SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) +{ + an = SCM_INUM (FETCH ()); /* the number of arguments */ + + vm_call: + /* + * Subprogram call + */ + if (SCM_PROGRAM_P (ac)) + { + /* Create a new frame */ + SCM *last_fp = fp; + SCM *last_sp = sp + an; + VM_NEW_FRAME (fp, ac, + SCM_VM_MAKE_ADDRESS (last_fp), + SCM_VM_MAKE_ADDRESS (last_sp), + SCM_VM_MAKE_ADDRESS (pc)); + VM_CALL_HOOK (); + + /* Jump to the program */ + pc = SCM_PROGRAM_BASE (ac); + VM_APPLY_HOOK (); + NEXT; + } + /* + * Function call + */ + if (!SCM_FALSEP (scm_procedure_p (ac))) + { + /* Construct an argument list */ + SCM list = SCM_EOL; + POP_LIST (an, list); + RETURN (scm_apply (ac, list, SCM_EOL)); + } + /* + * Continuation call + */ + if (SCM_VM_CONT_P (ac)) + { + vm_call_cc: + /* Check the number of arguments */ + if (an != 1) + scm_wrong_num_args (ac); + + /* Reinstate the continuation */ + SCM_VM_REINSTATE_CONT (vmp, ac); + LOAD (); + POP (ac); /* return value */ + VM_RETURN_HOOK (); + NEXT; + } + + SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac)); +} + +/* Before: + ac = program + pc[0] = the number of arguments + + After: + pc = program's address +*/ +SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) +{ + an = SCM_INUM (FETCH ()); /* the number of arguments */ + + /* + * Subprogram call + */ + if (SCM_PROGRAM_P (ac)) + { + if (SCM_EQ_P (ac, SCM_VM_FRAME_PROGRAM (fp))) + /* Tail recursive call */ + { + /* Setup arguments */ + int nvars = SCM_PROGRAM_NVARS (ac); /* the number of local vars */ + int nreqs = SCM_PROGRAM_NREQS (ac); /* the number of require args */ + int restp = SCM_PROGRAM_RESTP (ac); /* have a rest argument */ + VM_SETUP_ARGS (ac, nreqs, restp); + + /* Move arguments */ + nreqs += restp; + while (nreqs-- > 0) + { + SCM obj; + POP (obj); + SCM_VM_FRAME_VARIABLE (fp, nvars++) = obj; + } + VM_EXPORT_ARGS (fp, ac); + } + else + /* Dynamic return call */ + { + /* Create a new frame */ + SCM *p = fp; + VM_NEW_FRAME (fp, ac, + SCM_VM_FRAME_DYNAMIC_LINK (p), + SCM_VM_FRAME_STACK_POINTER (p), + SCM_VM_FRAME_RETURN_ADDRESS (p)); + VM_CALL_HOOK (); + } + + /* Jump to the program */ + pc = SCM_PROGRAM_BASE (ac); + VM_APPLY_HOOK (); + NEXT; + } + /* + * Function call + */ + if (!SCM_FALSEP (scm_procedure_p (ac))) + { + /* Construct an argument list */ + SCM list = SCM_EOL; + POP_LIST (an, list); + ac = scm_apply (ac, list, SCM_EOL); + goto vm_return; + } + /* + * Continuation call + */ + if (SCM_VM_CONT_P (ac)) + goto vm_call_cc; + + SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac)); +} + +SCM_DEFINE_INSTRUCTION (return, "%return", INST_NONE) +{ + SCM *last_fp; + vm_return: + VM_RETURN_HOOK (); + last_fp = fp; + fp = SCM_VM_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (last_fp)); + sp = SCM_VM_ADDRESS (SCM_VM_FRAME_STACK_POINTER (last_fp)); + pc = SCM_VM_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (last_fp)); + NEXT; +} diff --git a/test/Makefile.am b/test/Makefile.am new file mode 100644 index 000000000..87daf1f15 --- /dev/null +++ b/test/Makefile.am @@ -0,0 +1,16 @@ +SOURCE_FILES = control.scm procedure.scm queens.scm +COMPILED_FILES = control.scc procedure.scc queens.scc +EXTRA_DIST = test.scm $(SOURCE_FILES) +CLEANFILES = $(COMPILED_FILES) +MAINTAINERCLEANFILES = Makefile.in + +GUILE = $(top_srcdir)/src/$(PACKAGE) + +test: $(COMPILED_FILES) + @for file in $(COMPILED_FILES); do \ + $(GUILE) -s test.scm $$file; \ + done + +SUFFIXES = .scm .scc +.scm.scc: + guile-compile $< diff --git a/test/control.scm b/test/control.scm new file mode 100644 index 000000000..2ae9ee78a --- /dev/null +++ b/test/control.scm @@ -0,0 +1,20 @@ + +(define income-tax + (lambda (income) + (cond + ((<= income 10000) + (* income .05)) + ((<= income 20000) + (+ (* (- income 10000) .08) + 500.00)) + ((<= income 30000) + (+ (* (- income 20000) .13) + 1300.00)) + (else + (+ (* (- income 30000) .21) + 2600.00))))) + +(test (income-tax 5000) 250.0) +(test (income-tax 15000) 900.0) +(test (income-tax 25000) 1950.0) +(test (income-tax 50000) 6800.0) diff --git a/test/procedure.scm b/test/procedure.scm new file mode 100644 index 000000000..5a25e59a9 --- /dev/null +++ b/test/procedure.scm @@ -0,0 +1,60 @@ +(define length + (lambda (ls) + (if (null? ls) + 0 + (+ (length (cdr ls)) 1)))) + +(test (length '()) 0) +(test (length '(a)) 1) +(test (length '(a b)) 2) + +(define remv + (lambda (x ls) + (cond + ((null? ls) '()) + ((eqv? (car ls) x) (remv x (cdr ls))) + (else (cons (car ls) (remv x (cdr ls))))))) + +(test (remv 'a '(a b b d)) '(b b d)) +(test (remv 'b '(a b b d)) '(a d)) +(test (remv 'c '(a b b d)) '(a b b d)) +(test (remv 'd '(a b b d)) '(a b b)) + +(define tree-copy + (lambda (tr) + (if (not (pair? tr)) + tr + (cons (tree-copy (car tr)) + (tree-copy (cdr tr)))))) + +(test (tree-copy '((a . b) . c)) '((a . b) . c)) + +(define quadratic-formula + (lambda (a b c) + (let ((root1 0) (root2 0) (minusb 0) (radical 0) (divisor 0)) + (set! minusb (- 0 b)) + (set! radical (sqrt (- (* b b) (* 4 (* a c))))) + (set! divisor (* 2 a)) + (set! root1 (/ (+ minusb radical) divisor)) + (set! root2 (/ (- minusb radical) divisor)) + (cons root1 root2)))) + +(test (quadratic-formula 2 -4 -6) '(3.0 . -1.0)) + +(define count + (let ((n 0)) + (lambda () + (set! n (1+ n)) + n))) + +(test (count) 1) +(test (count) 2) + +(define (fibonacci i) + (cond ((= i 0) 0) + ((= i 1) 1) + (else (+ (fibonacci (- i 1)) (fibonacci (- i 2)))))) + +(test (fibonacci 0) 0) +(test (fibonacci 5) 5) +(test (fibonacci 10) 55) diff --git a/test/queens.scm b/test/queens.scm new file mode 100644 index 000000000..66e8f0ce7 --- /dev/null +++ b/test/queens.scm @@ -0,0 +1,50 @@ +(define (filter predicate sequence) + (cond ((null? sequence) '()) + ((predicate (car sequence)) + (cons (car sequence) + (filter predicate (cdr sequence)))) + (else (filter predicate (cdr sequence))))) + +(define (accumulate op initial sequence) + (if (null? sequence) + initial + (op (car sequence) + (accumulate op initial (cdr sequence))))) + +(define (flatmap proc seq) + (accumulate append '() (map proc seq))) + +(define (enumerate-interval low high) + (if (> low high) + '() + (cons low (enumerate-interval (+ low 1) high)))) + +(define empty-board '()) + +(define (rest bs k rest-of-queens) + (map (lambda (new-row) + (adjoin-position new-row k rest-of-queens)) + (enumerate-interval 1 bs))) + +(define (queen-cols board-size k) + (if (= k 0) + (list empty-board) + (filter (lambda (positions) (safe? k positions)) + (flatmap (lambda (r) (rest board-size k r)) + (queen-cols board-size (- k 1)))))) + +(define (queens board-size) + (queen-cols board-size board-size)) + +(define (adjoin-position new-row k rest-of-queens) + (append rest-of-queens (list new-row))) + +(define (safe? k positions) + (let ((new (car (last-pair positions))) + (bottom (car positions))) + (cond ((= k 1) #t) + ((= new bottom) #f) + ((or (= new (- bottom (- k 1))) (= new (+ bottom (- k 1)))) #f) + (else (safe? (- k 1) (cdr positions)))))) + +(test (queens 4) '((2 4 1 3) (3 1 4 2))) diff --git a/test/test.scm b/test/test.scm new file mode 100644 index 000000000..fd08af322 --- /dev/null +++ b/test/test.scm @@ -0,0 +1,12 @@ + +(set! %load-path (cons ".." %load-path)) +(use-modules (vm vm)) + +(define (test a b) + (if (equal? a b) + (display "OK\n") + (display "failed\n"))) + +(let ((file (cadr (command-line)))) + (format #t "Testing ~S...\n" file) + (load file)) diff --git a/vm/Makefile.am b/vm/Makefile.am new file mode 100644 index 000000000..91d1b37cd --- /dev/null +++ b/vm/Makefile.am @@ -0,0 +1,14 @@ +vmdatadir = $(datadir)/guile/vm +vmdata_DATA = utils.scm types.scm bytecomp.scm compile.scm shell.scm +noinst_DATA = libvm.so + +EXTRA_DIST = $(vmdata_DATA) +CLEANFILES = $(noinst_DATA) +MAINTAINERCLEANFILES = Makefile.in + +libvm.so: + $(LN_S) -f ../src/.libs/libguilevm.so ./libvm.so + +install-data-local: + rm -f $(vmdatadir)/libvm.so \ + && $(LN_S) $(libdir)/libguilevm.so $(vmdatadir)/libvm.so diff --git a/vm/bytecomp.scm b/vm/bytecomp.scm new file mode 100644 index 000000000..d46016b79 --- /dev/null +++ b/vm/bytecomp.scm @@ -0,0 +1,500 @@ +;;; bytecomp.scm --- convert an intermediate code to an assemble code + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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 VM 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 VM; 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 (vm bytecomp) + :use-module (vm vm) + :use-module (vm utils) + :use-module (vm types) + :export (byte-compile)) + +(define (byte-compile nreqs restp code) + (vector (byte-header nreqs restp (code-env code)) + (byte-finalize (byte-optimize (byte-translate code))))) + + +;;; +;;; Bytecode header +;;; + +(define (byte-header nreqs restp env) + (list->vector (cons* nreqs restp (env-header env)))) + + +;;; +;;; Bytecode translation +;;; + +(define (byte-translate code) + (let ((stack '())) + ;; push opcode + (define (push-code! . args) + (set! stack (cons args stack))) + (let trans ((code code) (use-stack #f) (tail #t)) + (let ((tag (code-tag code)) + (env (code-env code)) + (args (code-args code))) + ;;; + ;;; Utilities + ;;; + ;; push the result into the stack + (define (trans-use-stack code) (trans code #t #f)) + ;; just set the accumulator + (define (trans-non-stack code) (trans code #f #f)) + ;; code can be a tail position + (define (trans-tail code) (trans code #f tail)) + ;; set unspecified when a tail position + (define (unspecified-position) (if tail (push-code! '%load-unspecified))) + ;; return here when a tail position + (define (return-position) (if tail (push-code! '%return))) + ;; push the result into the stack + (define (push-position) (if use-stack (push-code! '%push))) + ;; return or push + (define (return-or-push) (return-position) (push-position)) + + ;;; + ;;; Translators + ;;; + (define (translate-unspecified) + ;; #:unspecified + ;; %load-unspecified + (push-code! '%load-unspecified) + (return-or-push)) + + (define (translate-constant obj) + ;; #:constant OBJ + ;; %pushc OBJ (if use-stack) + ;; %loadc OBJ (if non-stack) + (if use-stack + (push-code! '%pushc obj) + (push-code! '%loadc obj)) + (return-position)) + + (define (translate-local-var name var) + (let* ((offset (env-variable-address env var)) + (abbrev (string->symbol (format #f "~A:~A" name offset)))) + (if (instruction-name? abbrev) + (push-code! abbrev) + (push-code! name offset)))) + + (define (translate-external-var name var) + (let* ((addr (env-variable-address env var)) + (depth (car addr)) + (offset (cdr addr)) + (abbrev1 (string->symbol + (format #f "~A:~A" name depth))) + (abbrev2 (string->symbol + (format #f "~A:~A:~A" name depth offset)))) + (cond ((instruction-name? abbrev2) (push-code! abbrev2)) + ((instruction-name? abbrev1) (push-code! abbrev1 offset)) + (else (push-code! name addr))))) + + (define (translate-top-level-var name var) + (push-code! name (variable-name var))) + + (define (translate-local-ref var) + ;; #:ref # + ;; %pushl OFFSET (if use-stack) + ;; %loadl OFFSET (if non-stack) + (assert variable? var) + (translate-local-var (if use-stack '%pushl '%loadl) var) + (return-position)) + + (define (translate-external-ref var) + ;; #:ref # + ;; %pushe (DEPTH . OFFSET) (if use-stack) + ;; %loade (DEPTH . OFFSET) (if non-stack) + (assert variable? var) + (translate-external-var (if use-stack '%pushe '%loade) var) + (return-position)) + + (define (translate-top-level-ref var) + ;; #:ref # + ;; %pusht SYMBOL (if use-stack) + ;; %loadt SYMBOL (if non-stack) + (assert variable? var) + (translate-top-level-var (if use-stack '%pusht '%loadt) var) + (return-position)) + + (define (translate-local-set var obj) + ;; #:set # OBJ + ;; OBJ + ;; %savel OFFSET + (assert variable? var) + (trans-non-stack obj) + (translate-local-var '%savel var) + (unspecified-position) + (return-or-push)) + + (define (translate-external-set var obj) + ;; #:set # OBJ + ;; OBJ + ;; %savee (DEPTH . OFFSET) + (assert variable? var) + (trans-non-stack obj) + (translate-external-var '%savee var) + (unspecified-position) + (return-or-push)) + + (define (translate-top-level-set var obj) + ;; #:set # OBJ + ;; OBJ + ;; %savet SYMBOL + (assert variable? var) + (trans-non-stack obj) + (translate-top-level-var '%savet var) + (unspecified-position) + (return-or-push)) + + (define (translate-and . args) + ;; #:and ARG1 ARG2... + ;; ARG1 + ;; %br-if-not L0 + ;; ARG2 + ;; %br-if-not L0 + ;; ... + ;; L0: + (assert-for-each code? args) + (let ((L0 (make-label))) + (for-each (lambda (arg) + (trans-non-stack arg) + (push-code! '%br-if-not L0)) + args) + (push-code! #:label L0)) + (return-or-push)) + + (define (translate-or . args) + ;; #:or ARG1 ARG2... + ;; ARG1 + ;; %br-if L0 + ;; ARG2 + ;; %br-if L0 + ;; ... + ;; L0: + (assert-for-each code? args) + (let ((L0 (make-label))) + (for-each (lambda (arg) + (trans-non-stack arg) + (push-code! '%br-if L0)) + args) + (push-code! #:label L0)) + (return-or-push)) + + (define (translate-program nreqs restp code) + ;; #:make-program NREQS RESTP CODE + ;; %make-program BYTECODE + (push-code! '%make-program (byte-compile nreqs restp code)) + (return-or-push)) + + (define (translate-label label) + ;; #:label is processed by byte-finalize + (assert label? label) + (push-code! #:label label)) + + (define (translate-goto label) + ;; #:goto LABEL + ;; %jump ADDR (calculated in byte-finalize) + (assert label? label) + (push-code! '%jump label)) + + (define (translate-if test then else) + ;; #:if TEST THEN ELSE + ;; TEST + ;; %br-if-not L1 + ;; THEN (tail position) + ;; %jump L2 (if not tail) + ;; L1: ELSE (tail position) + ;; L2: + (assert code? test) + (assert code? then) + (assert code? else) + (let ((L1 (make-label)) + (L2 (make-label))) + (trans-non-stack test) + (push-code! '%br-if-not L1) + (trans-tail then) + (if (not tail) + (push-code! '%jump L2)) + (push-code! #:label L1) + (trans-tail else) + (push-code! #:label L2)) + (push-position)) + + (define (translate-until test . body) + ;; #:until TEST BODY... + ;; L0: TEST + ;; %br-if L1 + ;; BODY... + ;; %jump L0 + ;; L1: + (assert code? test) + (assert-for-each code? body) + (let ((L0 (make-label)) + (L1 (make-label))) + (push-code! #:label L0) + (trans-non-stack test) + (push-code! '%br-if L1) + (for-each trans-non-stack body) + (push-code! '%jump L0) + (push-code! #:label L1)) + (unspecified-position) + (return-position)) + + (define (translate-begin . body) + ;; #:begin BODY... TAIL + ;; BODY... + ;; TAIL (tail position) + (assert-for-each code? body) + (let* ((list (reverse body)) + (tail (car list)) + (body (reverse! (cdr list)))) + (for-each trans-non-stack body) + (trans-tail tail)) + (push-position)) + + (define (translate-regular-call code . args) + ;; #:call CODE ARGS... + ;; ARGS... (-> stack) + ;; CODE + ;; %(tail-)call NARGS + (let ((nargs (length args))) + (for-each trans-use-stack args) + (trans-non-stack code) + (if tail + (push-code! '%tail-call nargs) + (push-code! '%call nargs))) + (push-position)) + + (define (translate-function-call inst . args) + ;; #:call INST ARGS... + (let ((name (instruction-name inst)) + (nargs (length args))) + (cond + ((cadr (instruction-arity inst)) + ;; ARGS... (-> stack) + ;; INST NARGS + (for-each trans-use-stack args) + (push-code! name nargs)) + (else + (case nargs + ((0) + ;; INST + (push-code! name)) + ((1) + ;; ARG1 + ;; INST + (trans-non-stack (car args)) + (push-code! name)) + ((2) + ;; ARG1 (-> stack) + ;; ARG2 + ;; INST + (trans-use-stack (car args)) + (trans-non-stack (cadr args)) + (push-code! name)) + ((3) + ;; ARG1 (-> stack) + ;; ARG2 (-> stack) + ;; ARG3 + ;; INST + (trans-use-stack (car args)) + (trans-use-stack (cadr args)) + (trans-non-stack (caddr args)) + (push-code! name)))))) + (return-or-push)) + + (define (translate-call obj . args) + (assert-for-each code? args) + (if (variable? obj) + (if (eq? (variable-type obj) 'function) + (cond + ((and (variable-bound? obj) + (and-let* ((obj (variable-value obj)) + (def (assq-ref *vm-function-table* obj))) + (or (list-ref def (min (length args) 4)) + (error "Wrong number of arguments")))) + => (lambda (inst) + (apply translate-function-call inst args))) + ((top-level-variable? obj) + (apply translate-regular-call + (make-code #:ref env obj) args))) + (apply translate-regular-call + (make-code #:ref env obj) args)) + (apply translate-regular-call obj args))) + + ;;; + ;;; Dispatch + ;;; + (case tag + ((#:unspecified) + ;; #:unspecified + (check-nargs args = 0) + (translate-unspecified)) + ((#:constant) + ;; #:constant OBJ + (check-nargs args = 1) + (translate-constant (car args))) + ((#:ref) + ;; #:ref VAR + (check-nargs args = 1) + (let ((var (car args))) + (cond + ((local-variable? var) (translate-local-ref var)) + ((external-variable? var) (translate-external-ref var)) + ((top-level-variable? var) (translate-top-level-ref var))))) + ((#:set) + ;; #:set VAR OBJ + (check-nargs args = 2) + (let ((var (car args)) (obj (cadr args))) + (cond + ((local-variable? var) (translate-local-set var obj)) + ((external-variable? var) (translate-external-set var obj)) + ((top-level-variable? var) (translate-top-level-set var obj))))) + ((#:and) + ;; #:and ARGS... + (apply translate-and args)) + ((#:or) + ;; #:or ARGS... + (apply translate-or args)) + ((#:make-program) + ;; #:make-program NREQS RESTP CODE + (check-nargs args = 3) + (translate-program (car args) (cadr args) (caddr args))) + ((#:label) + ;; #:label LABEL + (check-nargs args = 1) + (translate-label (car args))) + ((#:goto) + ;; #:goto LABEL + (check-nargs args = 1) + (translate-goto (car args))) + ((#:if) + ;; #:if TEST THEN ELSE + (check-nargs args = 3) + (translate-if (car args) (cadr args) (caddr args))) + ((#:until) + ;; #:until TEST BODY... + (check-nargs args >= 2) + (apply translate-until (car args) (cdr args))) + ((#:begin) + ;; #:begin BODY... + (check-nargs args >= 1) + (apply translate-begin args)) + ((#:call) + ;; #:call OBJ ARGS... + (check-nargs args >= 1) + (apply translate-call (car args) (cdr args))) + (else + (error "Unknown tag:" tag))))) + ;; that's it for this stage + (reverse! stack))) + + +;;; +;;; Bytecode optimization +;;; + +(define (byte-optimize code) + (let loop ((last (car code)) (code (cdr code)) (result '())) + (define (continue) (loop (car code) (cdr code) (cons last result))) + (if (null? code) + (reverse! (cons last result)) + (let ((this (car code))) + (case (car this) + ((%br-if) + (case (car last) + ((null?) + (loop (cons '%br-if-null (cdr this)) (cdr code) result)) + (else + (continue)))) + ((%br-if-not) + (case (car last) + ((null?) + (loop (cons '%br-if-not-null (cdr this)) (cdr code) result)) + (else + (continue)))) + (else + (continue))))))) + + +;;; +;;; Bytecode finalization +;;; + +(define (byte-finalize code) + (let loop ((code code) (result '())) + (cond + ((null? code) + ;; Return the final assemble code + (let ((finalize (lambda (obj) + (if (label? obj) + (label-position obj) + obj)))) + (list->vector (reverse! (map finalize result))))) + ((eq? (caar code) #:label) + ;; Calculate the label position + (set! (label-position (cadar code)) (length result)) + (loop (cdr code) result)) + (else + ;; Append to the result + (loop (cdr code) (append! (reverse! (car code)) result)))))) + + +;;; +;;; Function table +;;; + +(define (functional-instruction-alist) + (let ((alist '())) + (define (add! name inst) + (let ((pair (assq name alist))) + (if pair + (set-cdr! pair (cons inst (cdr pair))) + (set! alist (acons name (list inst) alist))))) + (for-each (lambda (inst) + (and-let* ((name (instruction-scheme-name inst))) + (add! name inst))) + (instruction-list)) + alist)) + +(define (build-table-data pair) + (let ((name (car pair)) (insts (cdr pair))) + (let ((vec (make-vector 5 #f))) + (define (build-data! inst) + (let ((arity (instruction-arity inst))) + (let ((nargs (car arity)) + (restp (cadr arity))) + (if restp + (do ((i nargs (1+ i))) + ((>= i 4) + (vector-set! vec 4 inst)) + (if (not (vector-ref vec i)) + (vector-set! vec i inst))) + (vector-set! vec nargs inst))))) + (for-each build-data! insts) + (let ((func (eval name (interaction-environment)))) + (cons func (vector->list vec)))))) + +(define *vm-function-table* + (map build-table-data (functional-instruction-alist))) + +;;; bytecomp.scm ends here diff --git a/vm/compile.scm b/vm/compile.scm new file mode 100644 index 000000000..14d25a490 --- /dev/null +++ b/vm/compile.scm @@ -0,0 +1,310 @@ +;;; compile.scm --- Compile Scheme codes + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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 VM 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 VM; 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 (vm compile) + :use-module (vm vm) + :use-module (vm utils) + :use-module (vm types) + :use-module (vm bytecomp) + :use-module (ice-9 syncase) + :export (compile compile-file)) + +(define (compile form . opts) + (catch 'result + (lambda () + (let ((x (syncase form))) + (if (or (memq #:e opts) (memq #:expand-only opts)) + (throw 'result x)) + (set! x (parse x (make-env '() (make-top-level-env)))) + (if (or (memq #:p opts) (memq #:parse-only opts)) + (throw 'result x)) + (set! x (byte-compile 0 #f x)) + (if (or (memq #:c opts) (memq #:compile-only opts)) + (throw 'result x)) + (make-program (make-bytecode x) #f))) + (lambda (key arg) arg))) + +(define (compile-file file) + (let ((out-file (string-append (substring file 0 (1- (string-length file))) + "c"))) + (with-input-from-file file + (lambda () + (with-output-to-file out-file + (lambda () + (format #t ";;; Compiled from ~A\n\n" file) + (display "(let ((vm (make-vm)))\n") + (display " (define (vm-exec code)\n") + (display " (vm-run vm (make-program (make-bytecode code) #f)))\n") + (do ((input (read) (read))) + ((eof-object? input)) + (display "(vm-exec ") + (write (compile input #:compile-only)) + (display ")\n")) + (display ")\n"))))))) + + +;;; +;;; Parser +;;; + +(define (parse x env) + (cond ((pair? x) (parse-pair x env)) + ((symbol? x) (make-code:ref env (env-ref env x))) + (else (make-code:constant env x)))) + +(define (parse-pair x env) + (let ((name (car x)) (args (cdr x))) + (if (assq name *syntax-alist*) + ;; syntax + ((assq-ref *syntax-alist* name) args env) + ;; procedure + (let ((proc (if (symbol? name) + (env-ref env name) + (parse name env)))) + (if (and (variable? proc) + (variable-bound? proc) + (assq (variable-value proc) *procedure-alist*)) + ;; procedure macro + ((assq-ref *procedure-alist* (variable-value proc)) args env) + ;; procedure call + (apply make-code:call env proc (map-parse args env))))))) + +(define (map-parse x env) + (map (lambda (x) (parse x env)) x)) + + +;;; +;;; Syntax +;;; + +(define *syntax-list* + '(quote lambda set! define if cond and or begin let let* letrec + local-set! until)) + +(define (parse-quote args env) + (make-code:constant env (car args))) + +(define (canon-formals formals) + ;; foo -> (() . foo) + ;; (foo bar baz) -> ((foo bar baz) . #f) + ;; (foo bar . baz) -> ((foo bar) . baz) + (cond ((symbol? formals) + (cons '() formals)) + ((or (null? formals) + (null? (cdr (last-pair formals)))) + (cons formals #f)) + (else + (let* ((copy (list-copy formals)) + (pair (last-pair copy)) + (last (cdr pair))) + (set-cdr! pair '()) + (cons copy last))))) + +(define (parse-lambda args env) + (let ((formals (car args)) (body (cdr args))) + (let* ((pair (canon-formals formals)) + (reqs (car pair)) + (rest (cdr pair)) + (syms (append reqs (if rest (list rest) '()))) + (new-env (make-env syms env))) + (make-code:program env (length reqs) (if rest #t #f) + (parse-begin body new-env))))) + +(define (parse-set! args env) + (let ((var (env-ref env (car args))) + (val (parse (cadr args) env))) + (variable-externalize! var) + (make-code:set env var val))) + +(define (parse-local-set! args env) + (let ((var (env-ref env (car args))) + (val (parse (cadr args) env))) + (make-code:set env var val))) + +(define (parse-define args env) + (parse-set! args env)) + +(define (parse-if args env) + (let ((test (parse (car args) env)) + (consequent (parse (cadr args) env)) + (alternate (if (null? (cddr args)) + (make-code:unspecified env) + (parse (caddr args) env)))) + (make-code:if env test consequent alternate))) + +;; FIXME: This should be expanded by syncase. +(define (parse-cond args env) + (cond ((null? args) (make-code:unspecified env)) + ((eq? (caar args) 'else) + (parse-begin (cdar args) env)) + (else + (let* ((clause (car args)) + (test (parse (car clause) env)) + (body (parse-begin (cdr clause) env)) + (alternate (parse-cond (cdr args) env))) + (make-code:if env test body alternate))))) + +(define (parse-and args env) + (apply make-code:and env (map-parse args env))) + +(define (parse-or args env) + (apply make-code:or env (map-parse args env))) + +(define (parse-begin args env) + (apply make-code:begin env (map-parse args env))) + +(define (%parse-let:finish env bindings init body) + (for-each (lambda (binding) + (env-remove-variable! env (car binding))) + bindings) + (apply make-code:begin env (append! init body))) + +(define (parse-let args env) + (if (symbol? (car args)) + ;; named let + (let ((tag (car args)) (bindings (cadr args)) (body (cddr args))) + (let* ((var (env-add-variable! env tag)) + (proc (parse-lambda (cons (map car bindings) body) env)) + (init (make-code:set env var proc)) + (call (apply make-code:call env var + (map-parse (map cadr bindings) env)))) + (env-remove-variable! env tag) + (make-code:begin env init call))) + ;; normal let + (let ((bindings (car args)) (body (cdr args))) + (let* (;; create values before binding + (vals (map-parse (map cadr bindings) env)) + ;; create bindings + (init (map (lambda (sym val) + (let ((var (env-add-variable! env sym))) + (make-code:set env var val))) + (map car bindings) vals))) + (%parse-let:finish env bindings init (map-parse body env)))))) + +(define (parse-let* args env) + (let ((bindings (car args)) (body (cdr args))) + (let (;; create values and bindings one after another + (init (map (lambda (binding) + (let* ((val (parse (cadr binding) env)) + (var (env-add-variable! env (car binding)))) + (make-code:set env var val))) + bindings))) + (%parse-let:finish env bindings init (map-parse body env))))) + +(define (parse-letrec args env) + (let ((bindings (car args)) (body (cdr args))) + (let* (;; create all variables before values + (vars (map (lambda (sym) + (env-add-variable! env sym)) + (map car bindings))) + ;; create and set values + (init (map (lambda (var val) + (make-code:set env var (parse val env))) + vars (map cadr bindings)))) + (%parse-let:finish env bindings init (map-parse body env))))) + +(define (parse-until args env) + (apply make-code:until env (parse (car args) env) + (map-parse (cdr args) env))) + +(define *syntax-alist* + (map (lambda (name) + (cons name (eval (symbol-append 'parse- name) (current-module)))) + *syntax-list*)) + + +;;; +;;; Procedure +;;; + +(define *procedure-list* + '(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + map for-each)) + +(define (parse-caar args env) (parse `(car (car ,@args)) env)) +(define (parse-cadr args env) (parse `(car (cdr ,@args)) env)) +(define (parse-cdar args env) (parse `(cdr (car ,@args)) env)) +(define (parse-cddr args env) (parse `(cdr (cdr ,@args)) env)) + +(define (parse-caaar args env) (parse `(car (car (car ,@args))) env)) +(define (parse-caadr args env) (parse `(car (car (cdr ,@args))) env)) +(define (parse-cadar args env) (parse `(car (cdr (car ,@args))) env)) +(define (parse-caddr args env) (parse `(car (cdr (cdr ,@args))) env)) +(define (parse-cdaar args env) (parse `(cdr (car (car ,@args))) env)) +(define (parse-cdadr args env) (parse `(cdr (car (cdr ,@args))) env)) +(define (parse-cddar args env) (parse `(cdr (cdr (car ,@args))) env)) +(define (parse-cdddr args env) (parse `(cdr (cdr (cdr ,@args))) env)) + +(define (parse-caaaar args env) (parse `(car (car (car (car ,@args)))) env)) +(define (parse-caaadr args env) (parse `(car (car (car (cdr ,@args)))) env)) +(define (parse-caadar args env) (parse `(car (car (cdr (car ,@args)))) env)) +(define (parse-caaddr args env) (parse `(car (car (cdr (cdr ,@args)))) env)) +(define (parse-cadaar args env) (parse `(car (cdr (car (car ,@args)))) env)) +(define (parse-cadadr args env) (parse `(car (cdr (car (cdr ,@args)))) env)) +(define (parse-caddar args env) (parse `(car (cdr (cdr (car ,@args)))) env)) +(define (parse-cadddr args env) (parse `(car (cdr (cdr (cdr ,@args)))) env)) +(define (parse-cdaaar args env) (parse `(cdr (car (car (car ,@args)))) env)) +(define (parse-cdaadr args env) (parse `(cdr (car (car (cdr ,@args)))) env)) +(define (parse-cdadar args env) (parse `(cdr (car (cdr (car ,@args)))) env)) +(define (parse-cdaddr args env) (parse `(cdr (car (cdr (cdr ,@args)))) env)) +(define (parse-cddaar args env) (parse `(cdr (cdr (car (car ,@args)))) env)) +(define (parse-cddadr args env) (parse `(cdr (cdr (car (cdr ,@args)))) env)) +(define (parse-cdddar args env) (parse `(cdr (cdr (cdr (car ,@args)))) env)) +(define (parse-cddddr args env) (parse `(cdr (cdr (cdr (cdr ,@args)))) env)) + +(define (parse-map args env) + (check-nargs args >= 2) + (case (length args) + ((2) + (let ((proc (car args)) (list (cadr args))) + (parse `(let ((list ,list) (result '())) + (until (null? list) + (local-set! result (cons (,proc (car list)) result)) + (local-set! list (cdr list))) + (reverse! result)) + env))) + (else + (error "Not implemented yet")))) + +(define (parse-for-each args env) + (check-nargs args >= 2) + (case (length args) + ((2) + (let ((proc (car args)) (list (cadr args))) + (parse `(let ((list ,list)) + (until (null? list) + (,proc (car list)) + (local-set! list (cdr list)))) + env))) + (else + (error "Not implemented yet")))) + +(define *procedure-alist* + (map (lambda (name) + (cons (eval name (current-module)) + (eval (symbol-append 'parse- name) (current-module)))) + *procedure-list*)) + +;;; compile.scm ends here diff --git a/vm/shell.scm b/vm/shell.scm new file mode 100644 index 000000000..375fe82af --- /dev/null +++ b/vm/shell.scm @@ -0,0 +1,221 @@ +;;; shell.scm --- interactive VM operations + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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 VM 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 VM; 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 (vm shell) + :use-module (vm vm) + :use-module (vm utils) + :use-module (vm compile) + :use-module (ice-9 format)) + +;;; +;;; VM Shell +;;; + +(define *vm-default-prompt* "VM> ") + +(define *vm-boot-message* "\ +Copyright (C) 2000 Free Software Foundation, Inc. +Guile VM is free software, covered by the GNU General Public License, +and you are welcome to change it and/or distribute copies of it under +certain conditions. There is absolutely no warranty for Guile VM.\n") + +(define (vm-init vm) + (vm-set-option! vm 'prompt *vm-default-prompt*) + (vm-set-option! vm 'verbose #f) + (vm-set-option! vm 'history-count 1)) + +(define-public (vm-boot vm) + (format #t "Guile Virtual Machine ~A\n" (vm-version)) + (display *vm-boot-message*) + (display "\nType \"help\" for information\n") + (vm-shell vm)) + +(define-public (vm-shell vm) + (vm-init vm) + (let ((read-expr (lambda () (read (current-input-port))))) + (let loop () + (display (or (vm-option vm 'prompt) *vm-default-prompt*)) + (let ((cmd (read-expr))) + (if (not (eof-object? cmd)) + (case cmd + ((eval) (vm-eval vm (read-expr)) (loop)) + ((trace) (vm-trace vm (read-expr)) (loop)) + ((parse) (vm-parse vm (read-expr)) (loop)) + ((compile) (vm-compile vm (read-expr)) (loop)) + ((set) (vm-set-option! vm (read-expr) (read-expr)) (loop)) + (else + (error "Unknown command: ~S" cmd)))))))) + +(define-public (vm-repl vm) + (vm-init vm) + (let loop () + (display (or (vm-option vm 'prompt) *vm-default-prompt*)) + (let ((form (read (current-input-port)))) + (if (not (eof-object? form)) + (begin + (vm-eval vm form) + (loop)))))) + +(define (vm-eval vm form) + (let ((result (vm-run vm (compile form)))) + (if (not (eq? result *unspecified*)) + (let* ((n (or (vm-option vm 'history-count) 1)) + (var (symbol-append "$" (number->string n)))) + (intern-symbol #f var) + (symbol-set! #f var result) + (format #t "~A = ~S\n" var result) + (vm-set-option! vm 'history-count (1+ n)) + result)))) + +(define (vm-parse vm form) + (parse form (make-top-level-env))) + +(define (vm-compile vm form) + #f) + + +;;; +;;; Step +;;; + +(define (vm-step-boot vm) + (format #t "VM: Starting a program ~S:~%" + (frame-program (vm-current-frame vm)))) + +(define (vm-step-halt vm) + (display "VM: Program terminated with the return value: ") + (display (vm:ac vm)) + (newline)) + +(define (vm-step-next vm) + (if (vm-option vm 'verbose) + (let ((frame (vm-current-frame vm))) + (display "--------------------------------------------------\n") + (format #t "PC = 0x~X SP = 0x~X FP = 0x~X AC = ~S~%" + (vm:pc vm) (vm:sp vm) (vm:fp vm) (vm:ac vm)) + (do ((frame frame (frame-dynamic-link frame)) + (frames '() (cons frame frames))) + ((not frame) + (for-each (lambda (frame) + (format #t "Frame = [~S 0x~X 0x~X]~%" + (frame-program frame) + (frame-stack-pointer frame) + (frame-return-address frame))) + frames))) + (format #t "Local variables = ~S~%" (frame-variables frame)) + (format #t "External variables = ~S~%" (program-external (frame-program frame))) + (format #t "Stack = ~S~%" (vm-stack->list vm)))) + (format #t "0x~X:" (vm:pc vm)) + (for-each (lambda (obj) (display " ") (write obj)) + (vm-fetch-code vm (vm:pc vm))) + (newline)) + +(define-public (vm-step vm form . opts) + (let ((debug-flag (vm-option vm 'debug))) + (dynamic-wind + (lambda () + (add-hook! (vm-boot-hook vm) vm-step-boot) + (add-hook! (vm-halt-hook vm) vm-step-halt) + (add-hook! (vm-next-hook vm) vm-step-next) + (vm-set-option! vm 'debug #t)) + (lambda () + (if (pair? opts) + (vm-set-option! vm 'verbose #t)) + (vm-run vm (compile form))) + (lambda () + (remove-hook! (vm-boot-hook vm) vm-step-boot) + (remove-hook! (vm-halt-hook vm) vm-step-halt) + (remove-hook! (vm-next-hook vm) vm-step-next) + (vm-set-option! vm 'debug debug-flag))))) + + +;;; +;;; Trace +;;; + +(define (vm-trace-prefix frame) + (and-let* ((link (frame-dynamic-link frame))) + (display "| ") + (vm-trace-prefix link))) + +(define (vm-frame->call frame) + (define (truncate! list n) + (let loop ((list list) (n n)) + (if (<= n 1) + (set-cdr! list '()) + (loop (cdr list) (1- n)))) + list) + (let* ((prog (frame-program frame)) + (name (or (program-name prog) prog))) + (cons name (reverse! (vector->list (frame-variables frame)))))) + +(define (vm-trace-apply vm) + (let ((frame (vm-current-frame vm))) + (vm-trace-prefix frame) + (display (vm-frame->call frame)) + (newline))) + +(define (vm-trace-return vm) + (vm-trace-prefix (vm-current-frame vm)) + (display (vm:ac vm)) + (newline)) + +(define-public (vm-trace vm form) + (let ((debug-flag (vm-option vm 'debug))) + (dynamic-wind + (lambda () + (add-hook! (vm-apply-hook vm) vm-trace-apply) + (add-hook! (vm-return-hook vm) vm-trace-return) + (vm-set-option! vm 'debug #t)) + (lambda () + (vm-run vm (compile form))) + (lambda () + (remove-hook! (vm-apply-hook vm) vm-trace-apply) + (remove-hook! (vm-return-hook vm) vm-trace-return) + (vm-set-option! vm 'debug debug-flag))))) + + +;;; +;;; Disassemble +;;; + +(define-public (disassemble program) + (format #t "Program at ~X:" (program-base program)) + (let ((subprogs '()) + (list (vector->list (bytecode-decode (program-code program))))) + (for-each (lambda (obj) + (cond ((opcode? obj) + (newline) + (display obj)) + ((program? obj) + (set! subprogs (cons subprogs obj)) + (display " ") + (display obj)) + (else + (display " ") + (display obj)))) + list) + (newline) + (for-each disassemble (reverse! subprogs)))) + +;;; shell.scm ends here diff --git a/vm/types.scm b/vm/types.scm new file mode 100644 index 000000000..cc8c4aff8 --- /dev/null +++ b/vm/types.scm @@ -0,0 +1,367 @@ +;;; types.scm --- data types used in the compiler and assembler + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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 VM 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 VM; 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 (vm types) + :use-module (vm vm) + :use-module (vm utils) + :use-module (oop goops)) + + +;;; +;;; VM code +;;; + +(define-class () + (tag #:accessor code-tag #:init-keyword #:tag) + (env #:accessor code-env #:init-keyword #:env) + (args #:accessor code-args #:init-keyword #:args) + (type #:accessor code-type #:init-value #f)) + +(export code-tag code-env code-args code-type) + +(define-method (write (obj ) port) + (display "#symbol (code-tag obj))) + (map (lambda (obj) (display " ") (write obj port)) + (code-args obj)) + (display ">")) + +(define-public (code? obj) + (is-a? obj )) + +(define-public (make-code tag env . args) + (make #:tag tag #:env env #:args args)) + + +;;; +;;; VM label +;;; + +(define-class () + (pos #:accessor label-position)) + +(export label-position) + +(define-public (label? obj) + (is-a? obj )) + +(define-public (make-label) + (make )) + + +;;; +;;; VM location +;;; + +(define-class ()) + +(define (make-location) + (make )) + + +;;; +;;; VM variable +;;; + +(define-class () + (name #:accessor variable-name #:init-keyword #:name) + (type #:accessor variable-type #:init-value #f) + (value #:accessor variable-value) + (loc #:accessor variable-location #:init-keyword #:location) + (count #:accessor variable-count #:init-value 0)) + +(define-class ()) +(define-class ()) +(define-class ()) + +(export variable-name variable-type variable-value variable-count) + +(define-method (write (obj ) port) + (display "#") + (display (class-name (class-of obj))) + (display " ") + (display (variable-name obj)) + (display ">")) + +(define-public (make-local-variable name location) + (make #:name name #:location location)) + +(define-public (make-top-level-variable name) + (make #:name name)) + +(define-public (variable? obj) + (is-a? obj )) + +(define-public (local-variable? obj) + (is-a? obj )) + +(define-public (external-variable? obj) + (is-a? obj )) + +(define-public (top-level-variable? obj) + (is-a? obj )) + +(define-public (variable-bound? var) + (assert variable? var) + (slot-bound? var 'value)) + +(define-public (variable-externalize! var) + (assert variable? var) + (if (local-variable? var) + (change-class var ))) + + +;;; +;;; VM environment +;;; + +(define-class () + (space #:accessor env-name-space #:init-value '()) + (args #:accessor env-arguments #:init-keyword #:args) + (vars #:accessor env-variables #:init-value '()) + (locs #:accessor env-locations #:init-value '()) + (exts #:accessor env-externals #:init-value #f) + (link #:accessor env-external-link #:init-keyword #:link)) + +(define-public (make-env syms link) + (let* ((syms (reverse syms)) + (args (map (lambda (sym) + (make-local-variable sym (make-location))) + syms)) + (env (make #:args args #:link link))) + (for-each (lambda (sym var) + (set! (env-name-space env) + (acons sym var (env-name-space env)))) + syms args) + env)) + +(define-public (make-top-level-env) + (make-env '() #f)) + +(define-public (env? obj) (is-a? obj )) + +(define-public (top-level-env? obj) + (and (env? obj) (not (env-external-link obj)))) + +(define-public (env-finalized? env) + (if (env-externals env) #t #f)) + +(define-public (env-add-variable! env sym) + (assert env? env) + (assert symbol? sym) + (if (env-finalized? env) + (error "You may not add a variable after finalization")) + (let ((var (if (top-level-env? env) + (make-top-level-variable sym) + (let* ((locs (env-locations env)) + (loc (if (null? locs) + (make-location) + (begin + (set! (env-locations env) (cdr locs)) + (car locs))))) + (make-local-variable sym loc))))) + (set! (env-name-space env) (acons sym var (env-name-space env))) + (set! (env-variables env) (cons var (env-variables env))) + var)) + +(define-public (env-remove-variable! env sym) + (assert env? env) + (assert symbol? sym) + (if (env-finalized? env) + (error "You may not remove a variable after finalization")) + (let ((var (assq-ref (env-name-space env) sym))) + (if (not var) + (error "No such variable: ~A\n" sym)) + (if (local-variable? var) + (set! (env-locations env) + (cons (variable-location var) (env-locations env)))) + (set! (env-name-space env) + (delq! (assq sym (env-name-space env)) (env-name-space env))) + var)) + +;; Find a varialbe in the environment + +(define-public (env-ref env sym) + (assert env? env) + (assert symbol? sym) + (if (env-finalized? env) + (error "You may not find a variable after finalization")) + (or (env-local-ref env sym) + (env-external-ref env sym) + (env-top-level-ref env sym) + (error "No way!"))) + +(define (env-local-ref env sym) + (if (assq sym (env-name-space env)) + (let ((var (assq-ref (env-name-space env) sym))) + (set! (variable-count var) (1+ (variable-count var))) + var) + #f)) + +(define (env-external-ref env sym) + (let ((ext-env (env-external-link env))) + (if (not ext-env) + #f + (let ((var (env-local-ref ext-env sym))) + (if var + (begin + (variable-externalize! var) + var) + (env-external-ref ext-env sym)))))) + +(define (env-top-level-ref env sym) + (let ((var (make-top-level-variable sym))) + (if (defined? sym) + ;; Get the value in the top-level + (let ((obj (eval sym (interaction-environment)))) + (set! (variable-value var) obj) + (set! (variable-type var) + (cond ((macro? obj) 'macro) + ((program? obj) 'program) + ((procedure? obj) 'function) + (else #f))))) + var)) + +;; Finalization + +(define-public (env-finalize! env) + (if (not (env-finalized? env)) + (let ((locs (uniq! (map variable-location + (append (filter local-variable? + (env-variables env)) + (env-arguments env))))) + (exts (filter external-variable? + (append (env-variables env) (env-arguments env))))) + (set! (env-locations env) locs) + (set! (env-externals env) (reverse! exts))))) + +(define-public (env-header env) + (env-finalize! env) + (let ((nvars (length (uniq! (map variable-location + (filter local-variable? + (env-variables env)))))) + (nexts (length (env-externals env))) + (exts (list->vector + (map (lambda (var) + (env-local-variable-address env var)) + (filter external-variable? + (reverse (env-arguments env))))))) + (list nvars nexts exts))) + +(define (get-offset obj list) + (- (length list) (length (memq obj list)))) + +(define-generic env-variable-address) + +(define-method (env-variable-address (env ) (var )) + (env-finalize! env) + (get-offset (variable-location var) (env-locations env))) + +(define-method (env-variable-address (env ) (var )) + (env-finalize! env) + (let loop ((depth 0) (env env)) + (let ((list (env-externals env))) + (cond ((null? list) + (loop depth (env-external-link env))) + ((memq var list) + (cons depth (get-offset var list))) + (else (loop (1+ depth) (env-external-link env))))))) + + +;;; +;;; Intermediate codes +;;; + +(define-public (make-code:unspecified env) + (assert env? env) + (make-code #:unspecified env)) + +(define-public (make-code:constant env obj) + (assert env? env) + (make-code #:constant env obj)) + +(define-public (make-code:ref env var) + (assert env? env) + (assert variable? var) + (let ((code (make-code #:ref env var))) + (set! (code-type code) (variable-type var)) + code)) + +(define-public (make-code:set env var val) + (assert env? env) + (assert variable? var) + (assert code? val) + (let ((code (make-code #:set env var val))) + (set! (variable-type var) (code-type val)) + (set! (code-type code) (variable-type var)) + code)) + +(define-public (make-code:program env nreqs restp body) + (assert env? env) + (assert integer? nreqs) + (assert boolean? restp) + (assert code? body) + (let ((code (make-code #:make-program env nreqs restp body))) + (set! (code-type code) 'program) + code)) + +(define-public (make-code:call env proc . args) + (assert env? env) + (assert (lambda (x) (or (variable? x) (code? x))) proc) + (assert-for-each code? args) + (apply make-code #:call env proc args)) + +(define-public (make-code:if env test consequent alternate) + (assert env? env) + (assert code? test) + (assert code? consequent) + (assert code? alternate) + (let ((code (make-code #:if env test consequent alternate))) + (if (eq? (code-type consequent) (code-type alternate)) + (set! (code-type code) (code-type consequent))) + code)) + +(define-public (make-code:and env . args) + (assert env? env) + (assert-for-each code? args) + (apply make-code #:and args)) + +(define-public (make-code:or env . args) + (assert env? env) + (assert-for-each code? args) + (apply make-code #:or args)) + +(define-public (make-code:begin env . body) + (assert env? env) + (assert-for-each code? body) + (let ((code (apply make-code #:begin env body))) + (set! (code-type code) (code-type (last body))) + code)) + +(define-public (make-code:until env test . body) + (assert env? env) + (assert code? test) + (assert-for-each code? body) + (apply make-code #:until env test body)) + +;;; types.scm ends here diff --git a/vm/utils.scm b/vm/utils.scm new file mode 100644 index 000000000..4a43375a3 --- /dev/null +++ b/vm/utils.scm @@ -0,0 +1,106 @@ +;;; utils.scm --- + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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 VM 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 VM; 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 (vm utils) + :use-module (ice-9 and-let*) + :use-module (ice-9 format)) + +(export and-let*) + +(define-public (assert predicate obj) + (if (not (predicate obj)) + (scm-error 'wrong-type-arg #f + "Wrong type argument: ~S, ~S" + (list (procedure-name predicate) obj) #f))) + +(define-public (assert-for-each predicate list) + (for-each (lambda (x) (assert predicate x)) list)) + +(define-public (check-nargs args pred n) + (if (not (pred (length args) n)) + (error "Too many or few arguments"))) + +(define-public (last list) + (car (last-pair list))) + +(define-public (rassq key alist) + (let loop ((alist alist)) + (cond ((null? alist) #f) + ((eq? key (cdar alist)) (car alist)) + (else (loop (cdr alist)))))) + +(define-public (rassq-ref alist key) + (let ((obj (rassq key alist))) + (if obj (car obj) #f))) + +(define-public (map-if pred func list) + (let loop ((list list) (result '())) + (if (null? list) + (reverse! result) + (if (pred (car list)) + (loop (cdr list) (cons (func (car list)) result)) + (loop (cdr list) result))))) + +(define-public (map-tree func tree) + (cond ((null? tree) '()) + ((pair? tree) + (cons (map-tree func (car tree)) (map-tree func (cdr tree)))) + (else (func tree)))) + +(define-public (filter pred list) + (let loop ((list list) (result '())) + (if (null? list) + (reverse! result) + (if (pred (car list)) + (loop (cdr list) (cons (car list) result)) + (loop (cdr list) result))))) + +(define-public (uniq! list) + (do ((rest list (begin (set-cdr! rest (delq! (car rest) (cdr rest))) + (cdr rest)))) + ((null? rest) list))) + +(define-public (finalize obj) + (if (promise? obj) (force obj) obj)) + +(export time) +(define-macro (time form) + `(let* ((gc-start (gc-run-time)) + (tms-start (times)) + (result ,form) + (tms-end (times)) + (gc-end (gc-run-time)) + (get (lambda (proc start end) + (/ (- (proc end) (proc start)) + internal-time-units-per-second)))) + (display "clock utime stime cutime cstime gc\n") + (format #t "~5a ~5a ~5a ~6a ~6a ~a~%" + (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 id gc-start gc-end)) + result)) + +;;; utils.scm ends here -- cgit v1.2.3 From 08d4430d38bedb0d41c37d978b49d8ccadfa9358 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 16:01:18 +0000 Subject: Initial import. --- .cvsignore | 9 +++++++++ doc/.cvsignore | 3 +++ src/.cvsignore | 15 +++++++++++++++ test/.cvsignore | 4 ++++ vm/.cvsignore | 3 +++ 5 files changed, 34 insertions(+) create mode 100644 .cvsignore create mode 100644 doc/.cvsignore create mode 100644 src/.cvsignore create mode 100644 test/.cvsignore create mode 100644 vm/.cvsignore diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 000000000..5b27a2a54 --- /dev/null +++ b/.cvsignore @@ -0,0 +1,9 @@ +.cvsignore +libtool +config.log +config.cache +config.status +configure +Makefile +Makefile.in +aclocal.m4 diff --git a/doc/.cvsignore b/doc/.cvsignore new file mode 100644 index 000000000..78ae5f382 --- /dev/null +++ b/doc/.cvsignore @@ -0,0 +1,3 @@ +.cvsignore +Makefile +Makefile.in diff --git a/src/.cvsignore b/src/.cvsignore new file mode 100644 index 000000000..97386bb58 --- /dev/null +++ b/src/.cvsignore @@ -0,0 +1,15 @@ +.cvsignore +.libs +.deps +guile-vm +stamp-h +config.h +config.h.in +stamp-h.in +Makefile +Makefile.in +*.x +*.vi +*.op +*.lo +*.la diff --git a/test/.cvsignore b/test/.cvsignore new file mode 100644 index 000000000..3f4d1f06e --- /dev/null +++ b/test/.cvsignore @@ -0,0 +1,4 @@ +.cvsignore +Makefile +Makefile.in +*.scc diff --git a/vm/.cvsignore b/vm/.cvsignore new file mode 100644 index 000000000..78ae5f382 --- /dev/null +++ b/vm/.cvsignore @@ -0,0 +1,3 @@ +.cvsignore +Makefile +Makefile.in -- cgit v1.2.3 From 307cdcf0d0cc37147bf72261d20c3924ddfac1dd Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 16:02:45 +0000 Subject: Add guile-compile. --- src/.cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/src/.cvsignore b/src/.cvsignore index 97386bb58..6f2800581 100644 --- a/src/.cvsignore +++ b/src/.cvsignore @@ -2,6 +2,7 @@ .libs .deps guile-vm +guile-compile stamp-h config.h config.h.in -- cgit v1.2.3 From fd329e8725074966ca5866352f3fd8ebecd5135a Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 17:39:49 +0000 Subject: types.scm (env-variable-address): Reverted the last change. --- vm/types.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/vm/types.scm b/vm/types.scm index cc8c4aff8..a06c3d18e 100644 --- a/vm/types.scm +++ b/vm/types.scm @@ -271,14 +271,19 @@ (define (get-offset obj list) (- (length list) (length (memq obj list)))) -(define-generic env-variable-address) - -(define-method (env-variable-address (env ) (var )) +(define-public (env-variable-address env var) (env-finalize! env) + (cond ((local-variable? var) + (env-local-variable-address env var)) + ((external-variable? var) + (env-external-variable-address env var)) + (else + (error "Wrong type argument: ~S" var)))) + +(define (env-local-variable-address env var) (get-offset (variable-location var) (env-locations env))) -(define-method (env-variable-address (env ) (var )) - (env-finalize! env) +(define (env-external-variable-address env var) (let loop ((depth 0) (env env)) (let ((list (env-externals env))) (cond ((null? list) -- cgit v1.2.3 From e54350691e7dd47d6823b86c960a43b6fa7fb6a7 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 18:25:36 +0000 Subject: (translate-and, translate-or): Don't branch on the last expression. --- vm/bytecomp.scm | 38 ++++++++++++++++++++++++-------------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/vm/bytecomp.scm b/vm/bytecomp.scm index d46016b79..076f38d3d 100644 --- a/vm/bytecomp.scm +++ b/vm/bytecomp.scm @@ -166,37 +166,47 @@ (return-or-push)) (define (translate-and . args) - ;; #:and ARG1 ARG2... + ;; #:and ARG1 ARG2... LAST ;; ARG1 ;; %br-if-not L0 ;; ARG2 ;; %br-if-not L0 ;; ... + ;; LAST ;; L0: (assert-for-each code? args) - (let ((L0 (make-label))) - (for-each (lambda (arg) - (trans-non-stack arg) - (push-code! '%br-if-not L0)) - args) - (push-code! #:label L0)) + (let* ((list (reverse args)) + (last (car list)) + (ARGS (reverse! (cdr list)))) + (let ((L0 (make-label))) + (for-each (lambda (arg) + (trans-non-stack arg) + (push-code! '%br-if-not L0)) + args) + (trans-non-stack last) + (push-code! #:label L0))) (return-or-push)) (define (translate-or . args) - ;; #:or ARG1 ARG2... + ;; #:or ARG1 ARG2... LAST ;; ARG1 ;; %br-if L0 ;; ARG2 ;; %br-if L0 ;; ... + ;; LAST ;; L0: (assert-for-each code? args) - (let ((L0 (make-label))) - (for-each (lambda (arg) - (trans-non-stack arg) - (push-code! '%br-if L0)) - args) - (push-code! #:label L0)) + (let* ((list (reverse args)) + (last (car list)) + (ARGS (reverse! (cdr list)))) + (let ((L0 (make-label))) + (for-each (lambda (arg) + (trans-non-stack arg) + (push-code! '%br-if L0)) + args) + (trans-non-stack last) + (push-code! #:label L0))) (return-or-push)) (define (translate-program nreqs restp code) -- cgit v1.2.3 From b1637a1ebd73b44d6889c13b2753ba69ae568b73 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 18:27:31 +0000 Subject: (make-code): Check argument types. (make-code:and, make-code:or): Pass env to make-code. --- vm/types.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/vm/types.scm b/vm/types.scm index a06c3d18e..f0d4c60f6 100644 --- a/vm/types.scm +++ b/vm/types.scm @@ -50,6 +50,8 @@ (is-a? obj )) (define-public (make-code tag env . args) + (assert keyword? tag) + (assert env? env) (make #:tag tag #:env env #:args args)) @@ -349,12 +351,12 @@ (define-public (make-code:and env . args) (assert env? env) (assert-for-each code? args) - (apply make-code #:and args)) + (apply make-code #:and env args)) (define-public (make-code:or env . args) (assert env? env) (assert-for-each code? args) - (apply make-code #:or args)) + (apply make-code #:or env args)) (define-public (make-code:begin env . body) (assert env? env) -- cgit v1.2.3 From dbb74d813720f348dca930a6a434abe17f6f42c6 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 18:44:19 +0000 Subject: (compile-file): Output "(use-modules (vm vm))". --- vm/compile.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/vm/compile.scm b/vm/compile.scm index 14d25a490..1510e90b5 100644 --- a/vm/compile.scm +++ b/vm/compile.scm @@ -52,6 +52,7 @@ (with-output-to-file out-file (lambda () (format #t ";;; Compiled from ~A\n\n" file) + (display "(use-modules (vm vm))\n\n") (display "(let ((vm (make-vm)))\n") (display " (define (vm-exec code)\n") (display " (vm-run vm (make-program (make-bytecode code) #f)))\n") -- cgit v1.2.3 From d608d68d7b653f809af3975de32f0ad17ee7e019 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 19:02:22 +0000 Subject: Create external frames dynamically. --- src/vm.c | 41 ++++++++++++++++------------------------- src/vm.h | 7 ++++--- src/vm_engine.c | 20 ++++++++++---------- src/vm_engine.h | 55 ++++++++++++++++++++++++++++++++++++------------------- src/vm_system.c | 21 ++++++++------------- 5 files changed, 74 insertions(+), 70 deletions(-) diff --git a/src/vm.c b/src/vm.c index 51fa23a8c..c614409f7 100644 --- a/src/vm.c +++ b/src/vm.c @@ -44,7 +44,7 @@ #include "vm.h" /* default stack size in the number of SCM */ -#define VM_DEFAULT_STACK_SIZE (1 * 1024) /* = 128KB */ +#define VM_DEFAULT_STACK_SIZE (16 * 1024) /* = 64KB */ #define VM_MAXIMUM_STACK_SIZE (1024 * 1024) /* = 4MB */ /* I sometimes use this for debugging. */ @@ -526,21 +526,9 @@ SCM_DEFINE (scm_bytecode_decode, "bytecode-decode", 1, 0, 0, static long scm_program_tag; static SCM -make_program (SCM bytecode, SCM parent) +make_program (SCM code, SCM env) { - SCM env = SCM_PROGRAM_P (parent) ? SCM_PROGRAM_ENV (parent) : SCM_BOOL_F; - int nexts = SCM_BYTECODE_NEXTS (bytecode); - - if (nexts) - { - SCM tmp = SCM_VM_MAKE_EXTERNAL (nexts); - SCM_VM_EXTERNAL_LINK (tmp) = env; - env = tmp; - } - - SCM_RETURN_NEWSMOB2 (scm_program_tag, - SCM_UNPACK (bytecode), - SCM_UNPACK (env)); + SCM_RETURN_NEWSMOB2 (scm_program_tag, SCM_UNPACK (code), SCM_UNPACK (env)); } static SCM @@ -629,16 +617,6 @@ SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0, - (SCM program), -"") -#define FUNC_NAME s_scm_program_external -{ - SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_ENV (program); -} -#undef FUNC_NAME - /* * VM Frame @@ -652,6 +630,7 @@ struct scm_vm_frame { SCM program; SCM variables; SCM dynamic_link; + SCM external_link; SCM stack_pointer; SCM return_address; }; @@ -668,6 +647,7 @@ make_vm_frame (SCM *fp) struct scm_vm_frame *p = scm_must_malloc (sizeof (*p), "make_vm_frame"); p->program = SCM_VM_FRAME_PROGRAM (fp); p->dynamic_link = SCM_VM_FRAME_DYNAMIC_LINK (fp); + p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (fp); p->stack_pointer = SCM_VM_FRAME_STACK_POINTER (fp); p->return_address = SCM_VM_FRAME_RETURN_ADDRESS (fp); @@ -688,6 +668,7 @@ mark_vm_frame (SCM frame) struct scm_vm_frame *p = SCM_VM_FRAME_DATA (frame); scm_gc_mark (p->program); scm_gc_mark (p->dynamic_link); + scm_gc_mark (p->external_link); return p->variables; } @@ -739,6 +720,16 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_external_link +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->external_link; +} +#undef FUNC_NAME + SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0, (SCM frame), "") diff --git a/src/vm.h b/src/vm.h index dc493bf5d..4de9a5039 100644 --- a/src/vm.h +++ b/src/vm.h @@ -188,13 +188,14 @@ extern SCM scm_program_base (SCM program); /* VM frame is allocated in the stack */ /* NOTE: Modify make_vm_frame and VM_NEW_FRAME too! */ -#define SCM_VM_FRAME_DATA_SIZE 5 +#define SCM_VM_FRAME_DATA_SIZE 6 #define SCM_VM_FRAME_VARIABLE(FP,N) (FP[N]) #define SCM_VM_FRAME_SIZE(FP) (FP[-1]) #define SCM_VM_FRAME_PROGRAM(FP) (FP[-2]) #define SCM_VM_FRAME_DYNAMIC_LINK(FP) (FP[-3]) -#define SCM_VM_FRAME_STACK_POINTER(FP) (FP[-4]) -#define SCM_VM_FRAME_RETURN_ADDRESS(FP) (FP[-5]) +#define SCM_VM_FRAME_EXTERNAL_LINK(FP) (FP[-4]) +#define SCM_VM_FRAME_STACK_POINTER(FP) (FP[-5]) +#define SCM_VM_FRAME_RETURN_ADDRESS(FP) (FP[-6]) /* diff --git a/src/vm_engine.c b/src/vm_engine.c index 2c6a1851c..20b80583f 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -61,24 +61,24 @@ VM_NAME (SCM vm, SCM program) #define FUNC_NAME "vm-engine" { /* Copies of VM registers */ - SCM ac = SCM_PACK (0); - SCM *pc = NULL; - SCM *sp = NULL; - SCM *fp = NULL; + SCM ac = SCM_PACK (0); /* accumulator */ + SCM *pc = NULL; /* program counter */ + SCM *sp = NULL; /* stack pointer */ + SCM *fp = NULL; /* frame pointer */ - /* Stack boundaries */ - SCM *stack_base = NULL; - SCM *stack_limit = NULL; + /* Cache variables */ + struct scm_vm *vmp = NULL; /* the VM data pointer */ + SCM ext = SCM_BOOL_F; /* the current external frame */ + SCM *stack_base = NULL; /* stack base address */ + SCM *stack_limit = NULL; /* stack limit address */ /* Function arguments */ int an = 0; SCM a2 = SCM_PACK (0); SCM a3 = SCM_PACK (0); - /* Miscellaneous variables */ + /* Internal variables */ SCM dynwinds = SCM_EOL; - struct scm_vm *vmp = NULL; - #if VM_USE_HOOK SCM hook_args = SCM_LIST1 (vm); #endif diff --git a/src/vm_engine.h b/src/vm_engine.h index 19493b301..c19aef588 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -237,7 +237,7 @@ */ /* an = the number of arguments */ -#define VM_SETUP_ARGS(PROG,NREQS,RESTP) \ +#define VM_FRAME_INIT_ARGS(PROG,NREQS,RESTP) \ { \ if (RESTP) \ /* have a rest argument */ \ @@ -260,49 +260,66 @@ } \ } -#define VM_EXPORT_ARGS(FP,PROG) \ -{ \ - int *exts = SCM_PROGRAM_EXTS (PROG); \ - if (exts) \ - { \ - int n = exts[0]; \ - while (n-- > 0) \ - SCM_VM_EXTERNAL_VARIABLE (SCM_PROGRAM_ENV (PROG), n) \ - = SCM_VM_FRAME_VARIABLE (FP, exts[n + 1]); \ - } \ -} - -#undef VM_FRAME_INIT_VARIABLES +#undef VM_FRAME_INIT_LOCAL_VARIABLES #if VM_INIT_LOCAL_VARIABLES /* This is necessary when creating frame objects for debugging */ -#define VM_FRAME_INIT_VARIABLES(FP,NVARS) \ +#define VM_FRAME_INIT_LOCAL_VARIABLES(FP,NVARS) \ { \ int i; \ for (i = 0; i < NVARS; i++) \ SCM_VM_FRAME_VARIABLE (FP, i) = SCM_UNDEFINED; \ } #else -#define VM_FRAME_INIT_VARIABLES(FP,NVARS) +#define VM_FRAME_INIT_LOCAL_VARIABLES(FP,NVARS) #endif +#define VM_FRAME_INIT_EXTERNAL_VARIABLES(FP,PROG) \ +{ \ + int *exts = SCM_PROGRAM_EXTS (PROG); \ + if (exts) \ + { \ + /* Export variables */ \ + int n = exts[0]; \ + while (n-- > 0) \ + SCM_VM_EXTERNAL_VARIABLE (ext, n) \ + = SCM_VM_FRAME_VARIABLE (FP, exts[n + 1]); \ + } \ +} + #define VM_NEW_FRAME(FP,PROG,DL,SP,RA) \ { \ int nvars = SCM_PROGRAM_NVARS (PROG); /* the number of local vars */ \ int nreqs = SCM_PROGRAM_NREQS (PROG); /* the number of required args */ \ int restp = SCM_PROGRAM_RESTP (PROG); /* have a rest argument or not */ \ + int nexts = SCM_PROGRAM_NEXTS (PROG); /* the number of external vars */ \ \ - VM_SETUP_ARGS (PROG, nreqs, restp); \ + VM_FRAME_INIT_ARGS (PROG, nreqs, restp); \ + \ + /* Allocate the new frame */ \ if (sp - nvars - SCM_VM_FRAME_DATA_SIZE < stack_base - 1) \ SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \ sp -= nvars + SCM_VM_FRAME_DATA_SIZE; \ FP = sp + SCM_VM_FRAME_DATA_SIZE + 1; \ + \ + /* Setup the new external frame */ \ + if (!SCM_FALSEP (SCM_PROGRAM_ENV (PROG))) \ + ext = SCM_PROGRAM_ENV (PROG); /* Use program's environment */ \ + if (nexts) \ + { \ + SCM new = SCM_VM_MAKE_EXTERNAL (nexts); /* new external */ \ + SCM_VM_EXTERNAL_LINK (new) = ext; \ + ext = new; \ + } \ + \ + /* Setup the new frame */ \ SCM_VM_FRAME_SIZE (FP) = SCM_MAKINUM (nvars); \ SCM_VM_FRAME_PROGRAM (FP) = PROG; \ SCM_VM_FRAME_DYNAMIC_LINK (FP) = DL; \ + SCM_VM_FRAME_EXTERNAL_LINK (FP) = ext; \ SCM_VM_FRAME_STACK_POINTER (FP) = SP; \ SCM_VM_FRAME_RETURN_ADDRESS (FP) = RA; \ - VM_FRAME_INIT_VARIABLES (FP, nvars); \ - VM_EXPORT_ARGS (FP, PROG); \ + VM_FRAME_INIT_LOCAL_VARIABLES (FP, nvars); \ + VM_FRAME_INIT_EXTERNAL_VARIABLES (FP, PROG); \ } diff --git a/src/vm_system.c b/src/vm_system.c index f07e5af22..fe13fcfb6 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -47,14 +47,12 @@ * Variable access */ -#undef LOCAL_VAR #define LOCAL_VAR(OFFSET) SCM_VM_FRAME_VARIABLE (fp, OFFSET) -#undef EXTERNAL_FOCUS #define EXTERNAL_FOCUS(DEPTH) \ { \ int depth = DEPTH; \ - env = SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)); \ + env = ext; \ while (depth-- > 0) \ { \ VM_ASSERT_LINK (env); \ @@ -62,16 +60,12 @@ } \ } -#undef EXTERNAL_VAR #define EXTERNAL_VAR(OFFSET) SCM_VM_EXTERNAL_VARIABLE (env, OFFSET) -#undef EXTERNAL_VAR0 -#define EXTERNAL_VAR0(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)), OFFSET) -#define EXTERNAL_VAR1(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp))), OFFSET) -#define EXTERNAL_VAR2(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_VM_EXTERNAL_LINK (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)))), OFFSET) +#define EXTERNAL_VAR0(OFFSET) SCM_VM_EXTERNAL_VARIABLE (ext, OFFSET) +#define EXTERNAL_VAR1(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (ext), OFFSET) +#define EXTERNAL_VAR2(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_VM_EXTERNAL_LINK (ext)), OFFSET) -#undef TOPLEVEL_VAR #define TOPLEVEL_VAR(CELL) SCM_CDR (CELL) -#undef TOPLEVEL_VAR_SET #define TOPLEVEL_VAR_SET(CELL,OBJ) SCM_SETCDR (CELL, OBJ) @@ -399,7 +393,7 @@ SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR) SCM_DEFINE_INSTRUCTION (make_program, "%make-program", INST_CODE) { SYNC (); /* must be called before GC */ - RETURN (SCM_MAKE_PROGRAM (FETCH (), SCM_VM_FRAME_PROGRAM (fp))); + RETURN (SCM_MAKE_PROGRAM (FETCH (), SCM_VM_FRAME_EXTERNAL_LINK (fp))); } /* Before: @@ -487,7 +481,7 @@ SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) int nvars = SCM_PROGRAM_NVARS (ac); /* the number of local vars */ int nreqs = SCM_PROGRAM_NREQS (ac); /* the number of require args */ int restp = SCM_PROGRAM_RESTP (ac); /* have a rest argument */ - VM_SETUP_ARGS (ac, nreqs, restp); + VM_FRAME_INIT_ARGS (ac, nreqs, restp); /* Move arguments */ nreqs += restp; @@ -497,7 +491,7 @@ SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) POP (obj); SCM_VM_FRAME_VARIABLE (fp, nvars++) = obj; } - VM_EXPORT_ARGS (fp, ac); + VM_FRAME_INIT_EXTERNAL_VARIABLES (fp, ac); } else /* Dynamic return call */ @@ -545,5 +539,6 @@ SCM_DEFINE_INSTRUCTION (return, "%return", INST_NONE) fp = SCM_VM_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (last_fp)); sp = SCM_VM_ADDRESS (SCM_VM_FRAME_STACK_POINTER (last_fp)); pc = SCM_VM_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (last_fp)); + ext = SCM_VM_FRAME_EXTERNAL_LINK (fp); NEXT; } -- cgit v1.2.3 From d545b41973c43dcfb25ee736d2391eebda053dec Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 19:03:32 +0000 Subject: Use frame-external-link. --- vm/shell.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/shell.scm b/vm/shell.scm index 375fe82af..bb5ea0508 100644 --- a/vm/shell.scm +++ b/vm/shell.scm @@ -123,7 +123,7 @@ certain conditions. There is absolutely no warranty for Guile VM.\n") (frame-return-address frame))) frames))) (format #t "Local variables = ~S~%" (frame-variables frame)) - (format #t "External variables = ~S~%" (program-external (frame-program frame))) + (format #t "External variables = ~S~%" (frame-external-link frame)) (format #t "Stack = ~S~%" (vm-stack->list vm)))) (format #t "0x~X:" (vm:pc vm)) (for-each (lambda (obj) (display " ") (write obj)) -- cgit v1.2.3 From db7880185f5e0bb85fd82f552394cff52d476701 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 19:03:57 +0000 Subject: *** empty log message *** --- ChangeLog | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/ChangeLog b/ChangeLog index 56b451d7b..b54c4a070 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,17 @@ +2000-08-22 Keisuke Nishida + + * src/vm.c, src/vm.h, src/vm_engine.c, src/vm_engine.h, + src/vm_system.c: Create external frames dynamically. + * vm/shell.scm: Use frame-external-link. + + * vm/compile.scm (compile-file): Output "(use-modules (vm vm))". + + * vm/types.scm (make-code): Check argument types. + (make-code:and, make-code:or): Pass env to make-code. + + * vm/bytecomp.scm (translate-and, translate-or): Don't branch on + the last expression. + 2000-08-20 Keisuke Nishida * Version 0.2 is released. -- cgit v1.2.3 From 9df03fd0c1a10c27866a2fa3fca499b18f1848ea Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 25 Aug 2000 02:31:26 +0000 Subject: * src/vm.c (lookup_variable): New function. (scm_make_bytecode): Call lookup_variable for top-level variables. * src/vm_engine.h (VM_VARIABLE_REF, VM_VARIABLE_SET): New macros. * src/vm_system.c (TOPLEVEL_VAR, TOPLEVEL_VAR_SET): Removed. Use VM_VARIABLE_REF and VM_VARIABLE_SET instead. --- src/vm.c | 14 +++++++++++++- src/vm_engine.h | 28 +++++++++++++++++----------- src/vm_system.c | 9 +++------ 3 files changed, 33 insertions(+), 18 deletions(-) diff --git a/src/vm.c b/src/vm.c index c614409f7..1fd5aa751 100644 --- a/src/vm.c +++ b/src/vm.c @@ -334,6 +334,18 @@ init_bytecode_type () scm_set_smob_free (scm_bytecode_tag, free_bytecode); } +/* Internal functions */ + +static SCM +lookup_variable (SCM sym) +{ + SCM closure = scm_standard_eval_closure (scm_selected_module ()); + SCM var = scm_apply (closure, SCM_LIST2 (sym, SCM_BOOL_F), SCM_EOL); + if (SCM_FALSEP (var)) + var = scm_apply (closure, SCM_LIST2 (sym, SCM_BOOL_T), SCM_EOL); + return var; +} + /* Scheme interface */ SCM_DEFINE (scm_bytecode_p, "bytecode?", 1, 0, 0, @@ -428,7 +440,7 @@ SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0, case INST_TOP: /* top-level variable */ SCM_VALIDATE_SYMBOL (1, old[i]); - new[i] = scm_intern0 (SCM_CHARS (old[i])); + new[i] = lookup_variable (old[i]); break; case INST_EXT: /* just copy for now */ diff --git a/src/vm_engine.h b/src/vm_engine.h index c19aef588..82699a9c7 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -95,17 +95,6 @@ * Type checking */ -#define VM_ASSERT_PROGRAM(OBJ) SCM_VALIDATE_PROGRAM (1, OBJ) - -#undef VM_ASSERT_BOUND -#if VM_CHECK_BINDING -#define VM_ASSERT_BOUND(CELL) \ - if (SCM_UNBNDP (SCM_CDR (CELL))) \ - SCM_MISC_ERROR ("Unbound variable: ~S", SCM_LIST1 (SCM_CAR (CELL))) -#else -#define VM_ASSERT_BOUND(CELL) -#endif - #undef VM_ASSERT_LINK #if VM_CHECK_LINK #define VM_ASSERT_LINK(OBJ) \ @@ -115,6 +104,23 @@ #define VM_ASSERT_LINK(OBJ) #endif + +/* + * Top-level variable + */ + +#define VM_VARIABLE_REF(VAR) SCM_CDDR (VAR) +#define VM_VARIABLE_SET(VAR,VAL) SCM_SETCDR (SCM_CDR (VAR), VAL) + +#undef VM_ASSERT_BOUND +#if VM_CHECK_BINDING +#define VM_ASSERT_BOUND(VAR) \ + if (SCM_UNBNDP (VM_VARIABLE_REF (VAR))) \ + SCM_MISC_ERROR ("Unbound variable: ~S", SCM_LIST1 (SCM_CADR (VAR))) +#else +#define VM_ASSERT_BOUND(CELL) +#endif + /* * Hooks diff --git a/src/vm_system.c b/src/vm_system.c index fe13fcfb6..324c30990 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -65,9 +65,6 @@ #define EXTERNAL_VAR1(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (ext), OFFSET) #define EXTERNAL_VAR2(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_VM_EXTERNAL_LINK (ext)), OFFSET) -#define TOPLEVEL_VAR(CELL) SCM_CDR (CELL) -#define TOPLEVEL_VAR_SET(CELL,OBJ) SCM_SETCDR (CELL, OBJ) - /* * Basic operations @@ -176,7 +173,7 @@ SCM_DEFINE_INSTRUCTION (pusht, "%pusht", INST_TOP) { ac = FETCH (); VM_ASSERT_BOUND (ac); - PUSH (TOPLEVEL_VAR (ac)); + PUSH (VM_VARIABLE_REF (ac)); NEXT; } @@ -257,7 +254,7 @@ SCM_DEFINE_INSTRUCTION (loadt, "%loadt", INST_TOP) { ac = FETCH (); VM_ASSERT_BOUND (ac); - RETURN (TOPLEVEL_VAR (ac)); + RETURN (VM_VARIABLE_REF (ac)); } @@ -338,7 +335,7 @@ SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP) { SCM cell = FETCH (); scm_set_object_property_x (ac, scm_sym_name, SCM_CAR (cell)); - TOPLEVEL_VAR_SET (cell, ac); + VM_VARIABLE_SET (cell, ac); NEXT; } -- cgit v1.2.3 From 12f9da005e26b2012ffb7adf78e227aa32710fd1 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 25 Aug 2000 02:31:43 +0000 Subject: *** empty log message *** --- ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ChangeLog b/ChangeLog index b54c4a070..0d346fda6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2000-08-24 Keisuke Nishida + + * src/vm.c (lookup_variable): New function. + (scm_make_bytecode): Call lookup_variable for top-level variables. + * src/vm_engine.h (VM_VARIABLE_REF, VM_VARIABLE_SET): New macros. + * src/vm_system.c (TOPLEVEL_VAR, TOPLEVEL_VAR_SET): Removed. + Use VM_VARIABLE_REF and VM_VARIABLE_SET instead. + 2000-08-22 Keisuke Nishida * src/vm.c, src/vm.h, src/vm_engine.c, src/vm_engine.h, -- cgit v1.2.3 From 382693febf5de06be7914962ac5535a8984e2150 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 2 Sep 2000 06:59:13 +0000 Subject: * src/vm_engine.c (VM_NAME): Renamed the variable `an\' to `nargs\'. Removed the variables `a2\' and `a3\'. * src/vm_engine.h (VM_SETUP_ARGS2, VM_SETUP_ARGS3): Setup local variables. (VM_SETUP_ARGS4): Removed. * src/vm_system.c, src/vm_scheme.c, src/vm_number.c: Updated. --- src/vm_engine.c | 6 +---- src/vm_engine.h | 18 +++++++------- src/vm_number.c | 76 +++++++++++++++++++++++++++++++-------------------------- src/vm_scheme.c | 24 ++++++++++-------- src/vm_system.c | 12 ++++----- 5 files changed, 71 insertions(+), 65 deletions(-) diff --git a/src/vm_engine.c b/src/vm_engine.c index 20b80583f..d3c21d291 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -72,12 +72,8 @@ VM_NAME (SCM vm, SCM program) SCM *stack_base = NULL; /* stack base address */ SCM *stack_limit = NULL; /* stack limit address */ - /* Function arguments */ - int an = 0; - SCM a2 = SCM_PACK (0); - SCM a3 = SCM_PACK (0); - /* Internal variables */ + int nargs = 0; /* the number of arguments */ SCM dynwinds = SCM_EOL; #if VM_USE_HOOK SCM hook_args = SCM_LIST1 (vm); diff --git a/src/vm_engine.h b/src/vm_engine.h index 82699a9c7..e8fb3cf88 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -203,10 +203,10 @@ X = cell; \ } -#define VM_SETUP_ARGS2() an = 2; a2 = ac; POP (ac); -#define VM_SETUP_ARGS3() an = 3; a3 = ac; POP (a2); POP (ac); -#define VM_SETUP_ARGS4() an = 4; a4 = ac; POP (a3); POP (a2); POP (ac); -#define VM_SETUP_ARGSN() an = SCM_INUM (FETCH ()); +#define VM_SETUP_ARGS1() SCM a1 = ac; +#define VM_SETUP_ARGS2() SCM a1, a2; a2 = ac; POP (a1); +#define VM_SETUP_ARGS3() SCM a1, a2, a3; a3 = ac; POP (a2); POP (a1); +#define VM_SETUP_ARGSN() nargs = SCM_INUM (FETCH ()); /* @@ -242,26 +242,26 @@ * Frame allocation */ -/* an = the number of arguments */ +/* nargs = the number of arguments */ #define VM_FRAME_INIT_ARGS(PROG,NREQS,RESTP) \ { \ if (RESTP) \ /* have a rest argument */ \ { \ SCM list; \ - if (an < NREQS) \ + if (nargs < NREQS) \ scm_wrong_num_args (PROG); \ \ /* Construct the rest argument list */ \ - an -= NREQS; /* the number of rest arguments */ \ + nargs -= NREQS; /* the number of rest arguments */ \ list = SCM_EOL; /* list of the rest arguments */ \ - POP_LIST (an, list); \ + POP_LIST (nargs, list); \ PUSH (list); \ } \ else \ /* not have a rest argument */ \ { \ - if (an != NREQS) \ + if (nargs != NREQS) \ scm_wrong_num_args (PROG); \ } \ } diff --git a/src/vm_number.c b/src/vm_number.c index 7bf709215..2346b669e 100644 --- a/src/vm_number.c +++ b/src/vm_number.c @@ -45,50 +45,54 @@ SCM_DEFINE_VM_FUNCTION (zero_p, "zero?", "zero?", 1, 0) { - if (SCM_INUMP (ac)) - RETURN (SCM_BOOL (SCM_EQ_P (ac, SCM_INUM0))); - RETURN (scm_zero_p (ac)); + VM_SETUP_ARGS1 (); + if (SCM_INUMP (a1)) + RETURN (SCM_BOOL (SCM_EQ_P (a1, SCM_INUM0))); + RETURN (scm_zero_p (a1)); } SCM_DEFINE_VM_FUNCTION (inc, "1+", "inc", 1, 0) { - if (SCM_INUMP (ac)) + VM_SETUP_ARGS1 (); + if (SCM_INUMP (a1)) { - int n = SCM_INUM (ac) + 1; + int n = SCM_INUM (a1) + 1; if (SCM_FIXABLE (n)) RETURN (SCM_MAKINUM (n)); } - RETURN (scm_sum (ac, SCM_MAKINUM (1))); + RETURN (scm_sum (a1, SCM_MAKINUM (1))); } SCM_DEFINE_VM_FUNCTION (dec, "1-", "dec", 1, 0) { - if (SCM_INUMP (ac)) + VM_SETUP_ARGS1 (); + if (SCM_INUMP (a1)) { - int n = SCM_INUM (ac) - 1; + int n = SCM_INUM (a1) - 1; if (SCM_FIXABLE (n)) RETURN (SCM_MAKINUM (n)); } - RETURN (scm_difference (ac, SCM_MAKINUM (1))); + RETURN (scm_difference (a1, SCM_MAKINUM (1))); } SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1) { VM_SETUP_ARGSN (); ac = SCM_MAKINUM (0); - while (an-- > 0) + while (nargs-- > 0) { - POP (a2); - if (SCM_INUMP (ac) && SCM_INUMP (a2)) + SCM x; + POP (x); + if (SCM_INUMP (ac) && SCM_INUMP (x)) { - int n = SCM_INUM (ac) + SCM_INUM (a2); + int n = SCM_INUM (ac) + SCM_INUM (x); if (SCM_FIXABLE (n)) { ac = SCM_MAKINUM (n); continue; } } - ac = scm_sum (ac, a2); + ac = scm_sum (ac, x); } NEXT; } @@ -96,71 +100,73 @@ SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1) SCM_DEFINE_VM_FUNCTION (add2, "+", "add2", 2, 0) { VM_SETUP_ARGS2 (); - if (SCM_INUMP (ac) && SCM_INUMP (a2)) + if (SCM_INUMP (a1) && SCM_INUMP (a2)) { - int n = SCM_INUM (ac) + SCM_INUM (a2); + int n = SCM_INUM (a1) + SCM_INUM (a2); if (SCM_FIXABLE (n)) RETURN (SCM_MAKINUM (n)); } - RETURN (scm_sum (ac, a2)); + RETURN (scm_sum (a1, a2)); } SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1) { + SCM x; VM_SETUP_ARGSN (); ac = SCM_MAKINUM (0); - while (an-- > 1) + while (nargs-- > 1) { - POP (a2); - if (SCM_INUMP (ac) && SCM_INUMP (a2)) + POP (x); + if (SCM_INUMP (ac) && SCM_INUMP (x)) { - int n = SCM_INUM (ac) + SCM_INUM (a2); + int n = SCM_INUM (ac) + SCM_INUM (x); if (SCM_FIXABLE (n)) { ac = SCM_MAKINUM (n); continue; } } - ac = scm_difference (ac, a2); + ac = scm_difference (ac, x); } - POP (a2); - if (SCM_INUMP (ac) && SCM_INUMP (a2)) + POP (x); + if (SCM_INUMP (ac) && SCM_INUMP (x)) { - int n = SCM_INUM (a2) - SCM_INUM (ac); + int n = SCM_INUM (x) - SCM_INUM (ac); if (SCM_FIXABLE (n)) RETURN (SCM_MAKINUM (n)); } - RETURN (scm_difference (a2, ac)); + RETURN (scm_difference (x, ac)); } SCM_DEFINE_VM_FUNCTION (sub2, "-", "sub2", 2, 0) { VM_SETUP_ARGS2 (); - if (SCM_INUMP (ac) && SCM_INUMP (a2)) + if (SCM_INUMP (a1) && SCM_INUMP (a2)) { - int n = SCM_INUM (ac) - SCM_INUM (a2); + int n = SCM_INUM (a1) - SCM_INUM (a2); if (SCM_FIXABLE (n)) RETURN (SCM_MAKINUM (n)); } - RETURN (scm_difference (ac, a2)); + RETURN (scm_difference (a1, a2)); } SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0) { - if (SCM_INUMP (ac)) + VM_SETUP_ARGS1 (); + if (SCM_INUMP (a1)) { - int n = - SCM_INUM (ac); + int n = - SCM_INUM (a1); if (SCM_FIXABLE (n)) RETURN (SCM_MAKINUM (n)); } - RETURN (scm_difference (ac, SCM_UNDEFINED)); + RETURN (scm_difference (a1, SCM_UNDEFINED)); } #define REL2(CREL,SREL) \ VM_SETUP_ARGS2 (); \ - if (SCM_INUMP (ac) && SCM_INUMP (a2)) \ - RETURN (SCM_BOOL (SCM_INUM (ac) CREL SCM_INUM (a2))); \ - RETURN (SREL (ac, a2)) + if (SCM_INUMP (a1) && SCM_INUMP (a2)) \ + RETURN (SCM_BOOL (SCM_INUM (a1) CREL SCM_INUM (a2))); \ + RETURN (SREL (a1, a2)) SCM_DEFINE_VM_FUNCTION (lt2, "<", "lt2", 2, 0) { diff --git a/src/vm_scheme.c b/src/vm_scheme.c index cfccbeda2..4b133a259 100644 --- a/src/vm_scheme.c +++ b/src/vm_scheme.c @@ -45,7 +45,8 @@ SCM_DEFINE_VM_FUNCTION (null_p, "null?", "null?", 1, 0) { - RETURN (SCM_BOOL (SCM_NULLP (ac))); + VM_SETUP_ARGS1 (); + RETURN (SCM_BOOL (SCM_NULLP (a1))); } SCM_DEFINE_VM_FUNCTION (cons, "cons", "cons", 2, 0) @@ -59,32 +60,35 @@ SCM_DEFINE_VM_FUNCTION (list, "list", "list", 0, 1) { VM_SETUP_ARGSN (); ac = SCM_EOL; - POP_LIST (an, ac); + POP_LIST (nargs, ac); NEXT; } SCM_DEFINE_VM_FUNCTION (car, "car", "car", 1, 0) { - SCM_VALIDATE_CONS (0, ac); - RETURN (SCM_CAR (ac)); + VM_SETUP_ARGS1 (); + SCM_VALIDATE_CONS (0, a1); + RETURN (SCM_CAR (a1)); } SCM_DEFINE_VM_FUNCTION (cdr, "cdr", "cdr", 1, 0) { - SCM_VALIDATE_CONS (0, ac); - RETURN (SCM_CDR (ac)); + VM_SETUP_ARGS1 (); + SCM_VALIDATE_CONS (0, a1); + RETURN (SCM_CDR (a1)); } SCM_DEFINE_VM_FUNCTION (not, "not", "not", 1, 0) { - RETURN (SCM_BOOL (SCM_FALSEP (ac))); + VM_SETUP_ARGS1 (); + RETURN (SCM_BOOL (SCM_FALSEP (a1))); } SCM_DEFINE_VM_FUNCTION (append, "append", "append", 0, 1) { VM_SETUP_ARGSN (); ac = SCM_EOL; - POP_LIST (an, ac); + POP_LIST (nargs, ac); RETURN (scm_append (ac)); } @@ -92,7 +96,7 @@ SCM_DEFINE_VM_FUNCTION (append_x, "append!", "append!", 0, 1) { VM_SETUP_ARGSN (); ac = SCM_EOL; - POP_LIST (an, ac); + POP_LIST (nargs, ac); RETURN (scm_append_x (ac)); } @@ -106,6 +110,6 @@ SCM_DEFINE_VM_FUNCTION (call_cc, "call-with-current-continuation", "call/cc", 1, { SYNC (); /* must sync all registers */ PUSH (SCM_VM_CAPTURE_CONT (vmp)); /* argument 1 */ - an = 1; /* the number of arguments */ + nargs = 1; /* the number of arguments */ goto vm_call; } diff --git a/src/vm_system.c b/src/vm_system.c index 324c30990..d3b2c02a9 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -402,7 +402,7 @@ SCM_DEFINE_INSTRUCTION (make_program, "%make-program", INST_CODE) */ SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) { - an = SCM_INUM (FETCH ()); /* the number of arguments */ + nargs = SCM_INUM (FETCH ()); /* the number of arguments */ vm_call: /* @@ -412,7 +412,7 @@ SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) { /* Create a new frame */ SCM *last_fp = fp; - SCM *last_sp = sp + an; + SCM *last_sp = sp + nargs; VM_NEW_FRAME (fp, ac, SCM_VM_MAKE_ADDRESS (last_fp), SCM_VM_MAKE_ADDRESS (last_sp), @@ -431,7 +431,7 @@ SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) { /* Construct an argument list */ SCM list = SCM_EOL; - POP_LIST (an, list); + POP_LIST (nargs, list); RETURN (scm_apply (ac, list, SCM_EOL)); } /* @@ -441,7 +441,7 @@ SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) { vm_call_cc: /* Check the number of arguments */ - if (an != 1) + if (nargs != 1) scm_wrong_num_args (ac); /* Reinstate the continuation */ @@ -464,7 +464,7 @@ SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) */ SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) { - an = SCM_INUM (FETCH ()); /* the number of arguments */ + nargs = SCM_INUM (FETCH ()); /* the number of arguments */ /* * Subprogram call @@ -514,7 +514,7 @@ SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) { /* Construct an argument list */ SCM list = SCM_EOL; - POP_LIST (an, list); + POP_LIST (nargs, list); ac = scm_apply (ac, list, SCM_EOL); goto vm_return; } -- cgit v1.2.3 From af8978be7451f7bb1b7cb4388a4faabec51234db Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 2 Sep 2000 07:00:02 +0000 Subject: *** empty log message *** --- ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index 0d346fda6..e3c798efe 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2000-09-02 Keisuke Nishida + + * src/vm_engine.c (VM_NAME): Renamed the variable `an' to `nargs'. + Removed the variables `a2' and `a3'. + * src/vm_engine.h (VM_SETUP_ARGS2, VM_SETUP_ARGS3): Setup local + variables. + (VM_SETUP_ARGS4): Removed. + * src/vm_system.c, src/vm_scheme.c, src/vm_number.c: Updated. + 2000-08-24 Keisuke Nishida * src/vm.c (lookup_variable): New function. -- cgit v1.2.3 From e6d41cdd75fae2b5538770ece42056252bcc540b Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 4 Sep 2000 01:47:10 +0000 Subject: * src/vm_system.c (tail_call): Use SCM_TICK at the beginning. --- src/vm_system.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/vm_system.c b/src/vm_system.c index d3b2c02a9..f75b7e783 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -464,6 +464,7 @@ SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) */ SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) { + SCM_TICK; /* allow interrupt here */ nargs = SCM_INUM (FETCH ()); /* the number of arguments */ /* @@ -488,17 +489,19 @@ SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) POP (obj); SCM_VM_FRAME_VARIABLE (fp, nvars++) = obj; } + VM_FRAME_INIT_EXTERNAL_VARIABLES (fp, ac); } else - /* Dynamic return call */ + /* Proper tail call */ { - /* Create a new frame */ - SCM *p = fp; + /* FIXME: Must remove the last frame. + FIXME: We need to move arguments before that. */ + SCM *last_fp = fp; VM_NEW_FRAME (fp, ac, - SCM_VM_FRAME_DYNAMIC_LINK (p), - SCM_VM_FRAME_STACK_POINTER (p), - SCM_VM_FRAME_RETURN_ADDRESS (p)); + SCM_VM_FRAME_DYNAMIC_LINK (last_fp), + SCM_VM_FRAME_STACK_POINTER (last_fp), + SCM_VM_FRAME_RETURN_ADDRESS (last_fp)); VM_CALL_HOOK (); } -- cgit v1.2.3 From 4405d598ef1d73cf75bf41fadeb8b2453539d623 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 4 Sep 2000 01:47:25 +0000 Subject: *** empty log message *** --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index e3c798efe..5460e4237 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2000-09-03 Keisuke Nishida + + * src/vm_system.c (tail_call): Use SCM_TICK at the beginning. + 2000-09-02 Keisuke Nishida * src/vm_engine.c (VM_NAME): Renamed the variable `an' to `nargs'. -- cgit v1.2.3 From 26403690174f05d933afab87e2e0313a4e4fe0df Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 10 Sep 2000 22:36:28 +0000 Subject: * src/vm_system.c (push_list): New instruction. * src/vm_engine.c (VM_NAME): Don\'t validate VM and PROGRAM. * src/vm.c (scm_vm_apply): New procedure. (apply_program): New function. (init_program_type): Set the apply function for the program type. * src/vm.c (lookup_variable): Use scm_eval_closure_lookup. --- src/vm.c | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++++---- src/vm_engine.c | 3 --- src/vm_system.c | 8 ++++++++ 3 files changed, 67 insertions(+), 7 deletions(-) diff --git a/src/vm.c b/src/vm.c index 1fd5aa751..53a572eca 100644 --- a/src/vm.c +++ b/src/vm.c @@ -339,10 +339,10 @@ init_bytecode_type () static SCM lookup_variable (SCM sym) { - SCM closure = scm_standard_eval_closure (scm_selected_module ()); - SCM var = scm_apply (closure, SCM_LIST2 (sym, SCM_BOOL_F), SCM_EOL); + SCM eclo = scm_standard_eval_closure (scm_selected_module ()); + SCM var = scm_eval_closure_lookup (eclo, sym, SCM_BOOL_F); if (SCM_FALSEP (var)) - var = scm_apply (closure, SCM_LIST2 (sym, SCM_BOOL_T), SCM_EOL); + var = scm_eval_closure_lookup (eclo, sym, SCM_BOOL_T); return var; } @@ -570,12 +570,22 @@ print_program (SCM obj, SCM port, scm_print_state *pstate) return 1; } +static SCM scm_vm_apply (SCM vm, SCM program, SCM args); +static SCM make_vm (int stack_size); + +static SCM +apply_program (SCM program, SCM args) +{ + return scm_vm_apply (make_vm (VM_DEFAULT_STACK_SIZE), program, args); +} + static void init_program_type () { scm_program_tag = scm_make_smob_type ("program", 0); scm_set_smob_mark (scm_program_tag, mark_program); scm_set_smob_print (scm_program_tag, print_program); + scm_set_smob_apply (scm_program_tag, apply_program, 0, 0, 1); } /* Scheme interface */ @@ -1115,7 +1125,7 @@ SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0, if (SCM_EQ_P (template[0], SCM_PACK (0))) { template[0] = VM_CODE ("%loadc"); - template[1] = SCM_BOOL_F; + template[1] = SCM_BOOL_F; /* overwritten */ template[2] = VM_CODE ("%call"); template[3] = SCM_MAKINUM (0); template[4] = VM_CODE ("%halt"); @@ -1140,6 +1150,51 @@ SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0, + (SCM vm, SCM program, SCM args), +"") +#define FUNC_NAME s_scm_vm_apply +{ + int len; + SCM bootcode; + static SCM template[7]; + + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_PROGRAM (2, program); + SCM_VALIDATE_LIST_COPYLEN (3, args, len); + + if (SCM_EQ_P (template[0], SCM_PACK (0))) + { + template[0] = VM_CODE ("%push-list"); + template[1] = SCM_EOL; /* overwritten */ + template[2] = VM_CODE ("%loadc"); + template[3] = SCM_BOOL_F; /* overwritten */ + template[4] = VM_CODE ("%call"); + template[5] = SCM_MAKINUM (0); /* overwritten */ + template[6] = VM_CODE ("%halt"); + } + + /* Create a boot program */ + bootcode = make_bytecode (7); + memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 7); + SCM_BYTECODE_BASE (bootcode)[1] = args; + SCM_BYTECODE_BASE (bootcode)[3] = program; + SCM_BYTECODE_BASE (bootcode)[5] = SCM_MAKINUM (len); + SCM_BYTECODE_SIZE (bootcode) = 7; + SCM_BYTECODE_EXTS (bootcode) = NULL; + SCM_BYTECODE_NREQS (bootcode) = 0; + SCM_BYTECODE_RESTP (bootcode) = 0; + SCM_BYTECODE_NVARS (bootcode) = 0; + SCM_BYTECODE_NEXTS (bootcode) = 0; + program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F); + + if (SCM_FALSEP (scm_vm_option (vm, sym_debug))) + return scm_regular_vm (vm, program); + else + return scm_debug_vm (vm, program); +} +#undef FUNC_NAME + /* * The VM engines diff --git a/src/vm_engine.c b/src/vm_engine.c index d3c21d291..dbf68c534 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -94,9 +94,6 @@ VM_NAME (SCM vm, SCM program) return SCM_UNSPECIFIED; } - SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_PROGRAM (2, program); - /* Initialize the VM */ vmp = SCM_VM_DATA (vm); vmp->pc = SCM_PROGRAM_BASE (program); diff --git a/src/vm_system.c b/src/vm_system.c index f75b7e783..47688fa27 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -94,6 +94,14 @@ SCM_DEFINE_INSTRUCTION (push, "%push", INST_NONE) NEXT; } +SCM_DEFINE_INSTRUCTION (push_list, "%push-list", INST_SCM) +{ + SCM list; + for (list = FETCH (); SCM_NIMP (list); list = SCM_CDR (list)) + PUSH (SCM_CAR (list)); + NEXT; +} + SCM_DEFINE_INSTRUCTION (pushc, "%pushc", INST_SCM) { PUSH (FETCH ()); -- cgit v1.2.3 From 307bd0a79487553e6f65e154f0f24d1820525edc Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 10 Sep 2000 22:36:39 +0000 Subject: *** empty log message *** --- ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/ChangeLog b/ChangeLog index 5460e4237..ab5ca86d2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2000-09-10 Keisuke Nishida + + * src/vm_system.c (push_list): New instruction. + * src/vm_engine.c (VM_NAME): Don't validate VM and PROGRAM. + * src/vm.c (scm_vm_apply): New procedure. + (apply_program): New function. + (init_program_type): Set the apply function for the program type. + + * src/vm.c (lookup_variable): Use scm_eval_closure_lookup. + 2000-09-03 Keisuke Nishida * src/vm_system.c (tail_call): Use SCM_TICK at the beginning. -- cgit v1.2.3 From a4908d56f4b3d80da1671603b34ec5e73f02aa8d Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 11 Sep 2000 09:18:49 +0000 Subject: * autogen.sh: Run aclocal with check where guile.m4 is installed. --- autogen.sh | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/autogen.sh b/autogen.sh index 15741faed..7aa465ef2 100755 --- a/autogen.sh +++ b/autogen.sh @@ -1,6 +1,16 @@ #!/bin/sh -aclocal +if test -f "`aclocal --print-ac-dir`/guile.m4"; then + aclocal +else + if test -f "`guile-config info datadir`/aclocal/guile.m4"; then + aclocal -I "`guile-config info datadir`/aclocal" + else + echo "Cannot find guile.m4"; + exit; + fi +fi + autoheader automake -a autoconf -- cgit v1.2.3 From 1304f8b274196feaa00f7ea8f64ea97681811444 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Mon, 11 Sep 2000 09:18:59 +0000 Subject: *** empty log message *** --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index ab5ca86d2..c79084ff5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2000-09-11 Keisuke Nishida + + * autogen.sh: Run aclocal with check where guile.m4 is installed. + 2000-09-10 Keisuke Nishida * src/vm_system.c (push_list): New instruction. -- cgit v1.2.3 From 6b81b7ae009834b7e8f939bdc5f46cb627f348e0 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 09:29:18 +0000 Subject: * src/vm_scheme.c (cons): Bug fixed. * src/vm_system.c (br_if_null): Set ac = SCM_BOOL_T if null. --- src/vm_scheme.c | 2 +- src/vm_system.c | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/vm_scheme.c b/src/vm_scheme.c index 4b133a259..3ab57f694 100644 --- a/src/vm_scheme.c +++ b/src/vm_scheme.c @@ -52,7 +52,7 @@ SCM_DEFINE_VM_FUNCTION (null_p, "null?", "null?", 1, 0) SCM_DEFINE_VM_FUNCTION (cons, "cons", "cons", 2, 0) { VM_SETUP_ARGS2 (); - CONS (ac, ac, a2); + CONS (ac, a1, a2); NEXT; } diff --git a/src/vm_system.c b/src/vm_system.c index 47688fa27..7d8d18282 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -372,7 +372,10 @@ SCM_DEFINE_INSTRUCTION (br_if_null, "%br-if-null", INST_ADDR) { SCM addr = FETCH (); /* must always fetch */ if (SCM_NULLP (ac)) - pc = SCM_VM_ADDRESS (addr); + { + ac = SCM_BOOL_T; + pc = SCM_VM_ADDRESS (addr); + } NEXT; } -- cgit v1.2.3 From a290fe7e0dd4d58657a3bf369a710643195197c4 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 09:29:31 +0000 Subject: *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index c79084ff5..00101aee2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2000-09-20 Keisuke Nishida + + * src/vm_scheme.c (cons): Bug fixed. + * src/vm_system.c (br_if_null): Set ac = SCM_BOOL_T if null. + 2000-09-11 Keisuke Nishida * autogen.sh: Run aclocal with check where guile.m4 is installed. -- cgit v1.2.3 From e6db4668ea81bf7b37076450bb6f91eb5b3a699e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 21:06:30 +0000 Subject: * src/vm.c (scm_name_property): New variable. (scm_name, scm_set_name_x): New procedures. (scm_smob_print_with_name, init_name_property): New functions. (print_program, scm_program_name): Removed. (init_program_type, init_vm_type): Use scm_smob_print_with_name. (scm_init_vm): Call init_name_property. --- src/vm.c | 89 ++++++++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 58 insertions(+), 31 deletions(-) diff --git a/src/vm.c b/src/vm.c index 53a572eca..b9eecf233 100644 --- a/src/vm.c +++ b/src/vm.c @@ -54,6 +54,61 @@ scm_newline (scm_def_errp); \ } + +/* + * Generic object name + */ + +static SCM scm_name_property; + +SCM_DEFINE (scm_name, "name", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_name +{ + return scm_primitive_property_ref (scm_name_property, obj); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_name_x, "set-name!", 2, 0, 0, + (SCM obj, SCM name), +"") +#define FUNC_NAME s_scm_set_name_x +{ + SCM_VALIDATE_SYMBOL (2, name); + return scm_primitive_property_set_x (scm_name_property, obj, name); +} +#undef FUNC_NAME + +int +scm_smob_print_with_name (SCM smob, SCM port, scm_print_state *pstate) +{ + int n = SCM_SMOBNUM (smob); + SCM name = scm_name (smob); + scm_puts ("#<", port); + scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); + scm_putc (' ', port); + if (SCM_FALSEP (name)) + { + scm_puts ("0x", port); + scm_intprint (SCM_UNPACK (scm_smobs[n].size ? SCM_CDR (smob) : smob), + 16, port); + } + else + { + scm_display (name, port); + } + scm_putc ('>', port); + return 1; +} + +static void +init_name_property () +{ + scm_name_property + = scm_permanent_object (scm_primitive_make_property (SCM_BOOL_F)); +} + /* * Instruction @@ -550,26 +605,6 @@ mark_program (SCM program) return SCM_PROGRAM_ENV (program); } -static SCM scm_program_name (SCM program); - -static int -print_program (SCM obj, SCM port, scm_print_state *pstate) -{ - SCM name = scm_program_name (obj); - scm_puts ("#', port); - return 1; -} - static SCM scm_vm_apply (SCM vm, SCM program, SCM args); static SCM make_vm (int stack_size); @@ -584,7 +619,7 @@ init_program_type () { scm_program_tag = scm_make_smob_type ("program", 0); scm_set_smob_mark (scm_program_tag, mark_program); - scm_set_smob_print (scm_program_tag, print_program); + scm_set_smob_print (scm_program_tag, scm_smob_print_with_name); scm_set_smob_apply (scm_program_tag, apply_program, 0, 0, 1); } @@ -609,16 +644,6 @@ SCM_DEFINE (scm_make_program, "make-program", 2, 0, 0, } #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_object_property (program, scm_sym_name); -} -#undef FUNC_NAME - SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0, (SCM program), "") @@ -890,6 +915,7 @@ init_vm_type () { scm_vm_tag = scm_make_smob_type ("vm", sizeof (struct scm_vm)); scm_set_smob_mark (scm_vm_tag, mark_vm); + scm_set_smob_print (scm_vm_tag, scm_smob_print_with_name); } /* Scheme interface */ @@ -1231,6 +1257,7 @@ scm_init_vm () scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)")); old_module = scm_select_module (scm_module_vm); + init_name_property (); init_instruction_type (); init_bytecode_type (); init_program_type (); -- cgit v1.2.3 From 4fdec843ed17fbee25660afd963b1b137d72a027 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 21:06:51 +0000 Subject: * src/vm_system.c (name): New instruction. (savet): Don't set name. --- src/vm_system.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/vm_system.c b/src/vm_system.c index 7d8d18282..3b1e04bbd 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -83,6 +83,14 @@ SCM_DEFINE_INSTRUCTION (halt, "%halt", INST_NONE) return ac; } +SCM_DEFINE_INSTRUCTION (name, "%name", INST_SCM) +{ + SCM name = FETCH (); + if (SCM_NIMP (name)) + scm_set_name_x (ac, name); + NEXT; +} + /* * %push family @@ -342,7 +350,6 @@ SCM_DEFINE_INSTRUCTION (savee_2, "%savee:2", INST_INUM) SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP) { SCM cell = FETCH (); - scm_set_object_property_x (ac, scm_sym_name, SCM_CAR (cell)); VM_VARIABLE_SET (cell, ac); NEXT; } -- cgit v1.2.3 From 3cdfcd54eb2160beb9bbf8762f7253b9b1d586c6 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 21:07:12 +0000 Subject: * vm/shell.scm (vm-frame->call): Updated. --- vm/shell.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/shell.scm b/vm/shell.scm index bb5ea0508..d3c09fe47 100644 --- a/vm/shell.scm +++ b/vm/shell.scm @@ -166,7 +166,7 @@ certain conditions. There is absolutely no warranty for Guile VM.\n") (loop (cdr list) (1- n)))) list) (let* ((prog (frame-program frame)) - (name (or (program-name prog) prog))) + (name (or (name prog) prog))) (cons name (reverse! (vector->list (frame-variables frame)))))) (define (vm-trace-apply vm) -- cgit v1.2.3 From 17a2034883f376468d97d9be955aadbcb336889f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 21:07:49 +0000 Subject: * vm/bytecomp.scm (translate-ref): Combined translate-local-ref, translate-external-ref, and translate-top-level-ref. (translate-set): Combined translate-local-set, translate-external-set, and translate-top-level-ref. Set a name to the object. (translate-and, translate-or): Bug fixed. --- vm/bytecomp.scm | 106 ++++++++++++++++++++++++-------------------------------- 1 file changed, 46 insertions(+), 60 deletions(-) diff --git a/vm/bytecomp.scm b/vm/bytecomp.scm index 076f38d3d..81bf6ec37 100644 --- a/vm/bytecomp.scm +++ b/vm/bytecomp.scm @@ -111,57 +111,51 @@ (define (translate-top-level-var name var) (push-code! name (variable-name var))) - (define (translate-local-ref var) - ;; #:ref # - ;; %pushl OFFSET (if use-stack) - ;; %loadl OFFSET (if non-stack) + (define (translate-ref var) (assert variable? var) - (translate-local-var (if use-stack '%pushl '%loadl) var) + (cond + ((local-variable? var) + ;; #:ref # + ;; %pushl OFFSET (if use-stack) + ;; %loadl OFFSET (if non-stack) + (translate-local-var (if use-stack '%pushl '%loadl) var)) + ((external-variable? var) + ;; #:ref # + ;; %pushe (DEPTH . OFFSET) (if use-stack) + ;; %loade (DEPTH . OFFSET) (if non-stack) + (translate-external-var (if use-stack '%pushe '%loade) var)) + ((top-level-variable? var) + ;; #:ref # + ;; %pusht SYMBOL (if use-stack) + ;; %loadt SYMBOL (if non-stack) + (translate-top-level-var (if use-stack '%pusht '%loadt) var))) (return-position)) - (define (translate-external-ref var) - ;; #:ref # - ;; %pushe (DEPTH . OFFSET) (if use-stack) - ;; %loade (DEPTH . OFFSET) (if non-stack) - (assert variable? var) - (translate-external-var (if use-stack '%pushe '%loade) var) - (return-position)) - - (define (translate-top-level-ref var) - ;; #:ref # - ;; %pusht SYMBOL (if use-stack) - ;; %loadt SYMBOL (if non-stack) - (assert variable? var) - (translate-top-level-var (if use-stack '%pusht '%loadt) var) - (return-position)) - - (define (translate-local-set var obj) - ;; #:set # OBJ - ;; OBJ - ;; %savel OFFSET - (assert variable? var) - (trans-non-stack obj) - (translate-local-var '%savel var) - (unspecified-position) - (return-or-push)) - - (define (translate-external-set var obj) - ;; #:set # OBJ - ;; OBJ - ;; %savee (DEPTH . OFFSET) - (assert variable? var) - (trans-non-stack obj) - (translate-external-var '%savee var) - (unspecified-position) - (return-or-push)) - - (define (translate-top-level-set var obj) - ;; #:set # OBJ - ;; OBJ - ;; %savet SYMBOL + (define (translate-set var obj) (assert variable? var) (trans-non-stack obj) - (translate-top-level-var '%savet var) + (cond + ((local-variable? var) + ;; #:set # OBJ + ;; OBJ + ;; %savel OFFSET + ;; %name NAME + (translate-local-var '%savel var)) + ((external-variable? var) + ;; #:set # OBJ + ;; OBJ + ;; %savee (DEPTH . OFFSET) + ;; %name NAME + (translate-external-var '%savee var)) + ((top-level-variable? var) + ;; #:set # OBJ + ;; OBJ + ;; %savet SYMBOL + ;; %name NAME + (translate-top-level-var '%savet var))) + ;; FIXME: Giving name to every objects is bad, but + ;; FIXME: this is useful for debugging. + (push-code! '%name (variable-name var)) (unspecified-position) (return-or-push)) @@ -177,13 +171,13 @@ (assert-for-each code? args) (let* ((list (reverse args)) (last (car list)) - (ARGS (reverse! (cdr list)))) + (args (reverse! (cdr list)))) (let ((L0 (make-label))) (for-each (lambda (arg) (trans-non-stack arg) (push-code! '%br-if-not L0)) args) - (trans-non-stack last) + (trans-tail last) (push-code! #:label L0))) (return-or-push)) @@ -199,13 +193,13 @@ (assert-for-each code? args) (let* ((list (reverse args)) (last (car list)) - (ARGS (reverse! (cdr list)))) + (args (reverse! (cdr list)))) (let ((L0 (make-label))) (for-each (lambda (arg) (trans-non-stack arg) (push-code! '%br-if L0)) args) - (trans-non-stack last) + (trans-tail last) (push-code! #:label L0))) (return-or-push)) @@ -366,19 +360,11 @@ ((#:ref) ;; #:ref VAR (check-nargs args = 1) - (let ((var (car args))) - (cond - ((local-variable? var) (translate-local-ref var)) - ((external-variable? var) (translate-external-ref var)) - ((top-level-variable? var) (translate-top-level-ref var))))) + (translate-ref (car args))) ((#:set) ;; #:set VAR OBJ (check-nargs args = 2) - (let ((var (car args)) (obj (cadr args))) - (cond - ((local-variable? var) (translate-local-set var obj)) - ((external-variable? var) (translate-external-set var obj)) - ((top-level-variable? var) (translate-top-level-set var obj))))) + (translate-set (car args) (cadr args))) ((#:and) ;; #:and ARGS... (apply translate-and args)) -- cgit v1.2.3 From 628ef8663eda862268a695bc3508f742483ba16e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 21:08:12 +0000 Subject: * src/vm_number.c (FUNC2): New macro. (add2, sub2): Use FUNC2. (remainder): New instruction. --- src/vm_number.c | 48 +++++++++++++++++++++++++++--------------------- 1 file changed, 27 insertions(+), 21 deletions(-) diff --git a/src/vm_number.c b/src/vm_number.c index 2346b669e..de7d7dd20 100644 --- a/src/vm_number.c +++ b/src/vm_number.c @@ -43,6 +43,26 @@ #include "vm-snarf.h" +#define FUNC2(CFUNC,SFUNC) \ +{ \ + VM_SETUP_ARGS2 (); \ + if (SCM_INUMP (a1) && SCM_INUMP (a2)) \ + { \ + int n = SCM_INUM (a1) CFUNC SCM_INUM (a2); \ + if (SCM_FIXABLE (n)) \ + RETURN (SCM_MAKINUM (n)); \ + } \ + RETURN (SFUNC (a1, a2)); \ +} + +#define REL2(CREL,SREL) \ +{ \ + VM_SETUP_ARGS2 (); \ + if (SCM_INUMP (a1) && SCM_INUMP (a2)) \ + RETURN (SCM_BOOL (SCM_INUM (a1) CREL SCM_INUM (a2))); \ + RETURN (SREL (a1, a2)); \ +} + SCM_DEFINE_VM_FUNCTION (zero_p, "zero?", "zero?", 1, 0) { VM_SETUP_ARGS1 (); @@ -99,14 +119,7 @@ SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1) SCM_DEFINE_VM_FUNCTION (add2, "+", "add2", 2, 0) { - VM_SETUP_ARGS2 (); - if (SCM_INUMP (a1) && SCM_INUMP (a2)) - { - int n = SCM_INUM (a1) + SCM_INUM (a2); - if (SCM_FIXABLE (n)) - RETURN (SCM_MAKINUM (n)); - } - RETURN (scm_sum (a1, a2)); + FUNC2 (+, scm_sum); } SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1) @@ -140,14 +153,7 @@ SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1) SCM_DEFINE_VM_FUNCTION (sub2, "-", "sub2", 2, 0) { - VM_SETUP_ARGS2 (); - if (SCM_INUMP (a1) && SCM_INUMP (a2)) - { - int n = SCM_INUM (a1) - SCM_INUM (a2); - if (SCM_FIXABLE (n)) - RETURN (SCM_MAKINUM (n)); - } - RETURN (scm_difference (a1, a2)); + FUNC2 (-, scm_difference); } SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0) @@ -162,11 +168,11 @@ SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0) RETURN (scm_difference (a1, SCM_UNDEFINED)); } -#define REL2(CREL,SREL) \ - VM_SETUP_ARGS2 (); \ - if (SCM_INUMP (a1) && SCM_INUMP (a2)) \ - RETURN (SCM_BOOL (SCM_INUM (a1) CREL SCM_INUM (a2))); \ - RETURN (SREL (a1, a2)) +SCM_DEFINE_VM_FUNCTION (remainder, "remainder", "remainder", 2, 0) +{ + VM_SETUP_ARGS2 (); + RETURN (scm_remainder (a1, a2)); +} SCM_DEFINE_VM_FUNCTION (lt2, "<", "lt2", 2, 0) { -- cgit v1.2.3 From 62edbc233006f1351a6ff0fd3f6f4146eab10024 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 21:08:25 +0000 Subject: *** empty log message *** --- ChangeLog | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/ChangeLog b/ChangeLog index 00101aee2..73d5a96bf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,26 @@ +2000-09-20 Keisuke Nishida + + * src/vm.c (scm_name_property): New variable. + (scm_name, scm_set_name_x): New procedures. + (scm_smob_print_with_name, init_name_property): New functions. + (print_program, scm_program_name): Removed. + (init_program_type, init_vm_type): Use scm_smob_print_with_name. + (scm_init_vm): Call init_name_property. + * src/vm_system.c (name): New instruction. + (savet): Don't set name. + * vm/shell.scm (vm-frame->call): Updated. + * vm/bytecomp.scm (translate-ref): Combined translate-local-ref, + translate-external-ref, and translate-top-level-ref. + (translate-set): Combined translate-local-set, + translate-external-set, and translate-top-level-ref. + Set a name to the object. + + * src/vm_number.c (FUNC2): New macro. + (add2, sub2): Use FUNC2. + (remainder): New instruction. + + * vm/bytecomp.scm (translate-and, translate-or): Bug fixed. + 2000-09-20 Keisuke Nishida * src/vm_scheme.c (cons): Bug fixed. -- cgit v1.2.3 From 38870b4313083460612989ca08fefe87c9e3bb50 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 21:13:12 +0000 Subject: * src/vm_system.c (br_if_not_null): Set ac = SCM_BOOL_F if not null. --- src/vm_system.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/vm_system.c b/src/vm_system.c index 3b1e04bbd..dbbbc601d 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -390,7 +390,10 @@ SCM_DEFINE_INSTRUCTION (br_if_not_null, "%br-if-not-null", INST_ADDR) { SCM addr = FETCH (); /* must always fetch */ if (!SCM_NULLP (ac)) - pc = SCM_VM_ADDRESS (addr); + { + ac = SCM_BOOL_F; + pc = SCM_VM_ADDRESS (addr); + } NEXT; } -- cgit v1.2.3 From dfa8d14a25c718d885601bf7096ec66ceb57c556 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 20 Sep 2000 21:13:26 +0000 Subject: *** empty log message *** --- ChangeLog | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog b/ChangeLog index 73d5a96bf..301fead5a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -25,6 +25,7 @@ * src/vm_scheme.c (cons): Bug fixed. * src/vm_system.c (br_if_null): Set ac = SCM_BOOL_T if null. + (br_if_not_null): Set ac = SCM_BOOL_F if not null. 2000-09-11 Keisuke Nishida -- cgit v1.2.3 From 89a6e8f7f346fee1ab3dd8c0bf0c593a1dd4f8dd Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 22 Sep 2000 11:08:17 +0000 Subject: * src/vm_system.c (call): Call return-hook before reinstating a continuation. (tail_call): Call return-hook before a proper tail call. --- src/vm_system.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/vm_system.c b/src/vm_system.c index dbbbc601d..a7cd19380 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -466,10 +466,10 @@ SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) scm_wrong_num_args (ac); /* Reinstate the continuation */ + VM_RETURN_HOOK (); SCM_VM_REINSTATE_CONT (vmp, ac); LOAD (); POP (ac); /* return value */ - VM_RETURN_HOOK (); NEXT; } @@ -519,6 +519,7 @@ SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) /* FIXME: Must remove the last frame. FIXME: We need to move arguments before that. */ SCM *last_fp = fp; + VM_RETURN_HOOK (); VM_NEW_FRAME (fp, ac, SCM_VM_FRAME_DYNAMIC_LINK (last_fp), SCM_VM_FRAME_STACK_POINTER (last_fp), -- cgit v1.2.3 From 19a84b86bb9261f4236913a744303273c3bc69e0 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 22 Sep 2000 11:08:28 +0000 Subject: *** empty log message *** --- ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ChangeLog b/ChangeLog index 301fead5a..445ef50db 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2000-09-22 Keisuke Nishida + + * src/vm_system.c (call): Call return-hook before reinstating a + continuation. + (tail_call): Call return-hook before a proper tail call. + 2000-09-20 Keisuke Nishida * src/vm.c (scm_name_property): New variable. -- cgit v1.2.3 From 04666c260c476cee2918a77b58b7814af6a3d76c Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 22 Sep 2000 17:38:36 +0000 Subject: * src/vm.c: SCM_CHARS -> SCM_SYMBOL_CHARS. --- src/vm.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/vm.c b/src/vm.c index b9eecf233..414ddb7f6 100644 --- a/src/vm.c +++ b/src/vm.c @@ -219,7 +219,7 @@ SCM_DEFINE (scm_instruction_name_p, "instruction-name?", 1, 0, 0, #define FUNC_NAME s_scm_instruction_name_p { SCM_VALIDATE_SYMBOL (1, name); - return SCM_BOOL (find_instruction_by_name (SCM_CHARS (name))); + return SCM_BOOL (find_instruction_by_name (SCM_SYMBOL_CHARS (name))); } #undef FUNC_NAME @@ -231,7 +231,7 @@ SCM_DEFINE (scm_symbol_to_instruction, "symbol->instruction", 1, 0, 0, struct scm_instruction *p; SCM_VALIDATE_SYMBOL (1, name); - p = find_instruction_by_name (SCM_CHARS (name)); + p = find_instruction_by_name (SCM_SYMBOL_CHARS (name)); if (!p) SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name)); @@ -472,7 +472,7 @@ SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0, /* Process instruction */ if (!SCM_SYMBOLP (old[i]) - || !(p = find_instruction_by_name (SCM_CHARS (old[i])))) + || !(p = find_instruction_by_name (SCM_SYMBOL_CHARS (old[i])))) SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old[i])); new[i] = SCM_ADDR_TO_CODE (p->addr); -- cgit v1.2.3 From 015959cb4a26738a391a0f276db876396edf74b5 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 22 Sep 2000 17:38:49 +0000 Subject: ChangeLog --- ChangeLog | 4 + doc/Makefile.am | 2 +- doc/guile-vm.texi | 504 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ doc/vm-spec.txt | 402 ------------------------------------------- vm/compile.scm | 59 +++---- 5 files changed, 539 insertions(+), 432 deletions(-) create mode 100644 doc/guile-vm.texi delete mode 100644 doc/vm-spec.txt diff --git a/ChangeLog b/ChangeLog index 445ef50db..5df9f6241 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2000-09-22 Keisuke Nishida + + * src/vm.c: SCM_CHARS -> SCM_SYMBOL_CHARS. + 2000-09-22 Keisuke Nishida * src/vm_system.c (call): Call return-hook before reinstating a diff --git a/doc/Makefile.am b/doc/Makefile.am index 3ab2c4b5b..892366bee 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -1,2 +1,2 @@ -EXTRA_DIST = vm-spec.txt +texi_TEXINFOS = guile-vm.texi MAINTAINERCLEANFILES = Makefile.in diff --git a/doc/guile-vm.texi b/doc/guile-vm.texi new file mode 100644 index 000000000..01130aa9c --- /dev/null +++ b/doc/guile-vm.texi @@ -0,0 +1,504 @@ +\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.3 +@set VERSION 0.3 +@set UPDATED 2000-08-22 + +@ifinfo +@dircategory Scheme Programming +@direntry +* Guile VM: (guile-vm). Guile Virtual Machine. +@end direntry + +This file documents Guile VM. + +Copyright @copyright{} 2000 Keisuke Nishida + +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 + +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 corresponds to Guile VM @value{VERSION}. + +@menu +@end menu + +@c ********************************************************************* +@node Introduction, Getting Started, 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. + +@unnumberdsubsec Registers + + pc - Program counter ;; ip (instruction poiner) is better? + sp - Stack pointer + bp - Base pointer + ac - Accumulator + +@unnumberdsubsec 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. + +@unnumberdsubsec 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. + +@unnumberdsubsec 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. + +@unnumberdsubsec 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 +@chapter Variable Management + +A program may have access to local variables, external variables, and +top-level variables. + +** 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. + + 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| | | + | +----------+ - | + | | | | | + +The first block of each frame may look like this: + + 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) + +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. + + local external + chain| | chain + | +-----+ .--------, | + `-|block|--+->|external|-' + /+-----+ | `--------'\, + `-|block|--' | + /+-----+ .--------, | + `-|block|---->|external|-' + +-----+ `--------' + | | + +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. + +** 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. + +*** Scheme and VM variable + +Let's think about the following Scheme code as an example: + + (define (foo a) + (lambda (b) (list foo a b))) + +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: + + block Top-level: foo + +-------------+ + |local var: b | fragment + +-------------+ .-----------, + |external link|---->|variable: a| + +-------------+ `-----------' + +The fragment remains as long as the closure exists. + +** Addressing mode + +Guile VM has five addressing modes: + + o Real address + o Local position + o External position + o Top-level location + o Constant object + +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? ] + +*** At a Glance + +Guile VM has a set of instructions for each instruction family. `%load' +is, for example, a family to load an object from memory and set the +accumulator (ac). There are four basic `%load' instructions: + + %loadl - Local addressing + %loade - External addressing + %loadt - Top-level addressing + %loadi - Immediate addressing + +A possible program code may look like this: + + %loadl (0 . 1) ; ac = local[0][1] + %loade (2 . 3) ; ac = external[2][3] + %loadt (foo . #) ; ac = # + %loadi "hello" ; ac = "hello" + +One instruction that uses real addressing is `%jump', which changes the +value of the program counter: + + %jump 0x80234ab8 ; pc = 0x80234ab8 + +* Program Execution + +Overall procedure: + + 1. A source program is compiled into a bytecode. + + 2. A bytecode is given an environment and becomes a program. + + 3. A VM starts execution, creating a frame for it. + + 4. Whenever a program calls a subprogram, a new frame is created for it. + + 5. When a program finishes execution, it returns a value, and the VM + continues execution of the parent program. + + 6. When all programs terminated, the VM returns the final value and stops. + +** Environment + +Local variable: + + (let ((a 1) (b 2) (c 3)) (+ a b c)) -> + + %pushi 1 ; a + %pushi 2 ; b + %pushi 3 ; c + %bind 3 ; create local bindings + %pushl (0 . 0) ; local variable a + %pushl (0 . 1) ; local variable b + %pushl (0 . 2) ; local variable c + add 3 ; ac = a + b + c + %unbind ; remove local bindings + +External variable: + + (define foo (let ((n 0)) (lambda () n))) + + %pushi 0 ; n + %bind 1 ; create local bindings + %export [0] ; make it an external variable + %make-program # ; create a program in this environment + %unbind ; remove local bindings + %savet (foo . #) ; save the program in foo + + (foo) -> + + %loadt (foo . #) ; program has an external link + %call 0 ; change the current external link + %loade (0 . 0) ; external variable n + %return ; recover the external link + +Top-level variable: + + foo -> + + %loadt (foo . #) ; top-level variable foo + +** Flow control + + (if #t 1 0) -> + + %loadi #t + %br-if-not L1 + %loadi 1 + %jump L2 + L1: %loadi 0 + L2: + +** Function call + +Builtin function: + + (1+ 2) -> + + %loadi 2 ; ac = 2 + 1+ ; one argument + + (+ 1 2) -> + + %pushi 1 ; 1 -> stack + %loadi 2 ; ac = 2 + add2 ; two argument + + (+ 1 2 3) -> + + %pushi 1 ; 1 -> stack + %pushi 2 ; 2 -> stack + %pushi 3 ; 3 -> stack + add 3 ; many argument + +External function: + + (version) -> + + %func0 (version . #) ; no argument + + (display "hello") -> + + %loadi "hello" + %func1 (display . #) ; one argument + + (open-file "file" "w") -> + + %pushi "file" + %loadi "w" + %func2 (open-file . #) ; two arguments + + (equal 1 2 3) + + %pushi 1 + %pushi 2 + %pushi 3 + %loadi 3 ; the number of arguments + %func (equal . #) ; many arguments + +** Subprogram call + + (define (plus a b) (+ a b)) + (plus 1 2) -> + + %pushi 1 ; argument 1 + %pushi 2 ; argument 2 + %loadt (plus . #) ; load the program + %call 2 ; call it with two arguments + %pushl (0 . 0) ; argument 1 + %loadl (0 . 1) ; argument 2 + add2 ; ac = 1 + 2 + %return ; result is 3 + +* 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. By convention, system instructions begin with a +letter `%'. + +** Environment control instructions + +- %alloc +- %bind +- %export +- %unbind + +** Subprogram control instructions + +- %make-program +- %call +- %return + +** Data control instructinos + +- %push +- %pushi +- %pushl, %pushl:0:0, %pushl:0:1, %pushl:0:2, %pushl:0:3 +- %pushe, %pushe:0:0, %pushe:0:1, %pushe:0:2, %pushe:0:3 +- %pusht + +- %loadi +- %loadl, %loadl:0:0, %loadl:0:1, %loadl:0:2, %loadl:0:3 +- %loade, %loade:0:0, %loade:0:1, %loade:0:2, %loade:0:3 +- %loadt + +- %savei +- %savel, %savel:0:0, %savel:0:1, %savel:0:2, %savel:0:3 +- %savee, %savee:0:0, %savee:0:1, %savee:0:2, %savee:0:3 +- %savet + +** Flow control instructions + +- %br-if +- %br-if-not +- %jump + +** Function call instructions + +- %func, %func0, %func1, %func2 + +** Scheme buitin functions + +- cons +- car +- cdr + +** Mathematical buitin functions + +- 1+ +- 1- +- add, add2 +- sub, sub2, minus +- mul2 +- div2 +- lt2 +- gt2 +- le2 +- ge2 +- num-eq2 + +@c ********************************************************************* +@node Concept Index, Command Index, Related Information, Top +@unnumbered Concept Index +@printindex cp + +@node Command Index, Variable Index, Concept Index, Top +@unnumbered Command Index +@printindex fn + +@node Variable Index, , Command Index, Top +@unnumbered Variable Index +@printindex vr + +@bye + +@c Local Variables: +@c mode:outline-minor +@c outline-regexp:"@\\(ch\\|sec\\|subs\\)" +@c End: diff --git a/doc/vm-spec.txt b/doc/vm-spec.txt deleted file mode 100644 index e3a04f5f1..000000000 --- a/doc/vm-spec.txt +++ /dev/null @@ -1,402 +0,0 @@ -Guile VM Specification -*- outline -*- -====================== -Updated: $Date: 2000/08/22 15:54:19 $ - -* Introduction - -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. - -** Registers - - pc - Program counter ;; ip (instruction poiner) is better? - sp - Stack pointer - bp - Base pointer - ac - Accumulator - -** 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. - -** 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. - -** 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. - -** 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. - -* Variable Management - -A program may have access to local variables, external variables, and -top-level variables. - -** 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. - - 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| | | - | +----------+ - | - | | | | | - -The first block of each frame may look like this: - - 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) - -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. - - local external - chain| | chain - | +-----+ .--------, | - `-|block|--+->|fragment|-' - /+-----+ | `--------'\, - `-|block|--' | - /+-----+ .--------, | - `-|block|---->|fragment|-' - +-----+ `--------' - | | - -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. - -** 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. - -*** Scheme and VM variable - -Let's think about the following Scheme code as an example: - - (define (foo a) - (lambda (b) (list foo a b))) - -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: - - block Top-level: foo - +-------------+ - |local var: b | fragment - +-------------+ .-----------, - |external link|---->|variable: a| - +-------------+ `-----------' - -The fragment remains as long as the closure exists. - -** Addressing mode - -Guile VM has five addressing modes: - - o Real address - o Local position - o External position - o Top-level location - o Immediate object - -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. - -Immediate object is not an address but gives an instruction an Scheme -object directly. - -[ We'll also need dynamic scope addressing to support Emacs Lisp? ] - -*** At a Glance - -Guile VM has a set of instructions for each instruction family. `%load' -is, for example, a family to load an object from memory and set the -accumulator (ac). There are four basic `%load' instructions: - - %loadl - Local addressing - %loade - External addressing - %loadt - Top-level addressing - %loadi - Immediate addressing - -A possible program code may look like this: - - %loadl (0 . 1) ; ac = local[0][1] - %loade (2 . 3) ; ac = external[2][3] - %loadt (foo . #) ; ac = # - %loadi "hello" ; ac = "hello" - -One instruction that uses real addressing is `%jump', which changes the -value of the program counter: - - %jump 0x80234ab8 ; pc = 0x80234ab8 - -* Program Execution - -Overall procedure: - - 1. A source program is compiled into a bytecode. - - 2. A bytecode is given an environment and becomes a program. - - 3. A VM starts execution, creating a frame for it. - - 4. Whenever a program calls a subprogram, a new frame is created for it. - - 5. When a program finishes execution, it returns a value, and the VM - continues execution of the parent program. - - 6. When all programs terminated, the VM returns the final value and stops. - -** Environment - -Local variable: - - (let ((a 1) (b 2) (c 3)) (+ a b c)) -> - - %pushi 1 ; a - %pushi 2 ; b - %pushi 3 ; c - %bind 3 ; create local bindings - %pushl (0 . 0) ; local variable a - %pushl (0 . 1) ; local variable b - %pushl (0 . 2) ; local variable c - add 3 ; ac = a + b + c - %unbind ; remove local bindings - -External variable: - - (define foo (let ((n 0)) (lambda () n))) - - %pushi 0 ; n - %bind 1 ; create local bindings - %export [0] ; make it an external variable - %make-program # ; create a program in this environment - %unbind ; remove local bindings - %savet (foo . #) ; save the program in foo - - (foo) -> - - %loadt (foo . #) ; program has an external link - %call 0 ; change the current external link - %loade (0 . 0) ; external variable n - %return ; recover the external link - -Top-level variable: - - foo -> - - %loadt (foo . #) ; top-level variable foo - -** Flow control - - (if #t 1 0) -> - - %loadi #t - %br-if-not L1 - %loadi 1 - %jump L2 - L1: %loadi 0 - L2: - -** Function call - -Builtin function: - - (1+ 2) -> - - %loadi 2 ; ac = 2 - 1+ ; one argument - - (+ 1 2) -> - - %pushi 1 ; 1 -> stack - %loadi 2 ; ac = 2 - add2 ; two argument - - (+ 1 2 3) -> - - %pushi 1 ; 1 -> stack - %pushi 2 ; 2 -> stack - %pushi 3 ; 3 -> stack - add 3 ; many argument - -External function: - - (version) -> - - %func0 (version . #) ; no argument - - (display "hello") -> - - %loadi "hello" - %func1 (display . #) ; one argument - - (open-file "file" "w") -> - - %pushi "file" - %loadi "w" - %func2 (open-file . #) ; two arguments - - (equal 1 2 3) - - %pushi 1 - %pushi 2 - %pushi 3 - %loadi 3 ; the number of arguments - %func (equal . #) ; many arguments - -** Subprogram call - - (define (plus a b) (+ a b)) - (plus 1 2) -> - - %pushi 1 ; argument 1 - %pushi 2 ; argument 2 - %loadt (plus . #) ; load the program - %call 2 ; call it with two arguments - %pushl (0 . 0) ; argument 1 - %loadl (0 . 1) ; argument 2 - add2 ; ac = 1 + 2 - %return ; result is 3 - -* 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. By convention, system instructions begin with a -letter `%'. - -** Environment control instructions - -- %alloc -- %bind -- %export -- %unbind - -** Subprogram control instructions - -- %make-program -- %call -- %return - -** Data control instructinos - -- %push -- %pushi -- %pushl, %pushl:0:0, %pushl:0:1, %pushl:0:2, %pushl:0:3 -- %pushe, %pushe:0:0, %pushe:0:1, %pushe:0:2, %pushe:0:3 -- %pusht - -- %loadi -- %loadl, %loadl:0:0, %loadl:0:1, %loadl:0:2, %loadl:0:3 -- %loade, %loade:0:0, %loade:0:1, %loade:0:2, %loade:0:3 -- %loadt - -- %savei -- %savel, %savel:0:0, %savel:0:1, %savel:0:2, %savel:0:3 -- %savee, %savee:0:0, %savee:0:1, %savee:0:2, %savee:0:3 -- %savet - -** Flow control instructions - -- %br-if -- %br-if-not -- %jump - -** Function call instructions - -- %func, %func0, %func1, %func2 - -** Scheme buitin functions - -- cons -- car -- cdr - -** Mathematical buitin functions - -- 1+ -- 1- -- add, add2 -- sub, sub2, minus -- mul2 -- div2 -- lt2 -- gt2 -- le2 -- ge2 -- num-eq2 diff --git a/vm/compile.scm b/vm/compile.scm index 1510e90b5..9baf2a40c 100644 --- a/vm/compile.scm +++ b/vm/compile.scm @@ -54,8 +54,8 @@ (format #t ";;; Compiled from ~A\n\n" file) (display "(use-modules (vm vm))\n\n") (display "(let ((vm (make-vm)))\n") - (display " (define (vm-exec code)\n") - (display " (vm-run vm (make-program (make-bytecode code) #f)))\n") + (display "(define (vm-exec code)") + (display "(vm-run vm (make-program (make-bytecode code) #f)))\n") (do ((input (read) (read))) ((eof-object? input)) (display "(vm-exec ") @@ -242,7 +242,8 @@ '(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - map for-each)) + ;;map for-each + )) (define (parse-caar args env) (parse `(car (car ,@args)) env)) (define (parse-cadr args env) (parse `(car (cdr ,@args)) env)) @@ -275,32 +276,32 @@ (define (parse-cdddar args env) (parse `(cdr (cdr (cdr (car ,@args)))) env)) (define (parse-cddddr args env) (parse `(cdr (cdr (cdr (cdr ,@args)))) env)) -(define (parse-map args env) - (check-nargs args >= 2) - (case (length args) - ((2) - (let ((proc (car args)) (list (cadr args))) - (parse `(let ((list ,list) (result '())) - (until (null? list) - (local-set! result (cons (,proc (car list)) result)) - (local-set! list (cdr list))) - (reverse! result)) - env))) - (else - (error "Not implemented yet")))) - -(define (parse-for-each args env) - (check-nargs args >= 2) - (case (length args) - ((2) - (let ((proc (car args)) (list (cadr args))) - (parse `(let ((list ,list)) - (until (null? list) - (,proc (car list)) - (local-set! list (cdr list)))) - env))) - (else - (error "Not implemented yet")))) +;(define (parse-map args env) +; (check-nargs args >= 2) +; (case (length args) +; ((2) +; (let ((proc (car args)) (list (cadr args))) +; (parse `(let ((list ,list) (result '())) +; (until (null? list) +; (local-set! result (cons (,proc (car list)) result)) +; (local-set! list (cdr list))) +; (reverse! result)) +; env))) +; (else +; (error "Not implemented yet")))) +; +;(define (parse-for-each args env) +; (check-nargs args >= 2) +; (case (length args) +; ((2) +; (let ((proc (car args)) (list (cadr args))) +; (parse `(let ((list ,list)) +; (until (null? list) +; (,proc (car list)) +; (local-set! list (cdr list)))) +; env))) +; (else +; (error "Not implemented yet")))) (define *procedure-alist* (map (lambda (name) -- cgit v1.2.3 From 4b482259c387d23e8b3aff4a348a63bc72252e2a Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 27 Sep 2000 23:29:45 +0000 Subject: Indirect threaded. Performance is the same as before. Wow\! --- src/.cvsignore | 5 ++-- src/Makefile.am | 15 ++++++---- src/vm-snarf.h | 26 +++++++++++++---- src/vm.c | 90 ++++++++++++++------------------------------------------- src/vm.h | 7 ++--- src/vm_engine.c | 23 ++++----------- src/vm_engine.h | 6 +--- 7 files changed, 64 insertions(+), 108 deletions(-) diff --git a/src/.cvsignore b/src/.cvsignore index 6f2800581..0ca232e65 100644 --- a/src/.cvsignore +++ b/src/.cvsignore @@ -10,7 +10,8 @@ stamp-h.in Makefile Makefile.in *.x -*.vi -*.op +*.inst +*.label +*.opcode *.lo *.la diff --git a/src/Makefile.am b/src/Makefile.am index 552690df9..c5b9b30b4 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -11,8 +11,9 @@ libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic noinst_HEADERS = vm.h vm_engine.h vm-snarf.h EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c \ test.scm guile-compile.in -BUILT_SOURCES = vm_system.vi vm_scheme.vi vm_number.vi \ - vm_system.op vm_scheme.op vm_number.op vm.x +BUILT_SOURCES = vm_system.inst vm_scheme.inst vm_number.inst \ + vm_system.label vm_scheme.label vm_number.label \ + vm_system.opcode vm_scheme.opcode vm_number.opcode vm.x CFLAGS = -g -O2 -Wall INCLUDES = $(GUILE_CFLAGS) @@ -21,16 +22,20 @@ DISTCLEANFILES = $(BUILT_SOURCES) MAINTAINERCLEANFILES = Makefile.in config.h.in stamp-h.in SNARF = guile-snarf -SUFFIXES = .x .vi .op +SUFFIXES = .x .inst .label .opcode .c.x: $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -.c.vi: +.c.inst: $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -.c.op: +.c.label: + $(SNARF) -DSCM_SNARF_LABEL $(DEFS) $(INCLUDES) $(CPPFLAGS) \ + $(CFLAGS) $< > $@ || { rm $@; false; } + +.c.opcode: $(SNARF) -DSCM_SNARF_OPCODE $(DEFS) $(INCLUDES) $(CPPFLAGS) \ $(CFLAGS) $< > $@ || { rm $@; false; } diff --git a/src/vm-snarf.h b/src/vm-snarf.h index 8956e32c9..8e35ac1a3 100644 --- a/src/vm-snarf.h +++ b/src/vm-snarf.h @@ -65,22 +65,36 @@ #else /* SCM_MAGIC_SNARFER */ #ifndef SCM_SNARF_OPCODE +#ifndef SCM_SNARF_LABEL /* - * These will go to *.vi + * These will go to *.inst */ #define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ - SCM_SNARF_INIT_START {VM_OPCODE(TAG), TYPE, NAME, VM_ADDR(TAG), SCM_BOOL_F, NULL, 0, 0}, + SCM_SNARF_INIT_START {VM_OPCODE(TAG), TYPE, NAME, SCM_BOOL_F, NULL, 0, 0}, #define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ - SCM_SNARF_INIT_START {VM_OPCODE(TAG), INST_NONE, NAME, VM_ADDR(TAG), SCM_BOOL_F, SNAME, NARGS, RESTP}, + SCM_SNARF_INIT_START {VM_OPCODE(TAG), INST_NONE, NAME, SCM_BOOL_F, SNAME, NARGS, RESTP}, +#else /* SCM_SNARF_LABEL */ + +/* + * These will go to *.label + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ + SCM_SNARF_INIT_START VM_ADDR(TAG), +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ + SCM_SNARF_INIT_START VM_ADDR(TAG), + +#endif /* SCM_SNARF_LABEL */ #else /* SCM_SNARF_OPCODE */ /* - * These will go to *.op + * These will go to *.opcode */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) SCM_SNARF_INIT_START VM_OPCODE(TAG), -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) SCM_SNARF_INIT_START VM_OPCODE(TAG), +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ + SCM_SNARF_INIT_START VM_OPCODE(TAG), +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ + SCM_SNARF_INIT_START VM_OPCODE(TAG), #endif /* SCM_SNARF_OPCODE */ #endif /* SCM_MAGIC_SNARFER */ diff --git a/src/vm.c b/src/vm.c index 414ddb7f6..43e554fff 100644 --- a/src/vm.c +++ b/src/vm.c @@ -114,21 +114,16 @@ init_name_property () * Instruction */ -#define INSTRUCTION_HASH_SIZE op_last -#define INSTRUCTION_HASH(ADDR) (((int) (ADDR) >> 1) % INSTRUCTION_HASH_SIZE) - -/* These variables are defined in VM engines when they are first called. */ -static struct scm_instruction *scm_regular_instruction_table = 0; -static struct scm_instruction *scm_debug_instruction_table = 0; +static long scm_instruction_tag; -/* Hash table for finding instructions from addresses */ -static struct inst_hash { - void *addr; - struct scm_instruction *inst; - struct inst_hash *next; -} *scm_instruction_hash_table[INSTRUCTION_HASH_SIZE]; +static struct scm_instruction scm_instruction_table[] = { +#include "vm_system.inst" +#include "vm_scheme.inst" +#include "vm_number.inst" + {op_last} +}; -static long scm_instruction_tag; +#define SCM_INSTRUCTION(OP) &scm_instruction_table[SCM_UNPACK (OP)] static SCM make_instruction (struct scm_instruction *instp) @@ -155,35 +150,15 @@ init_instruction_type () /* C interface */ static struct scm_instruction * -find_instruction_by_name (const char *name) +scm_lookup_instruction (const char *name) { struct scm_instruction *p; - for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + for (p = scm_instruction_table; p->opcode != op_last; p++) if (strcmp (name, p->name) == 0) return p; return 0; } -static struct scm_instruction * -find_instruction_by_code (SCM code) -{ - struct inst_hash *p; - void *addr = SCM_CODE_TO_ADDR (code); - for (p = scm_instruction_hash_table[INSTRUCTION_HASH (addr)]; p; p = p->next) - if (p->addr == addr) - return p->inst; - return 0; -} - -#ifdef HAVE_LABELS_AS_VALUES -static void * -instruction_code_to_debug_addr (SCM code) -{ - struct scm_instruction *p = find_instruction_by_code (code); - return scm_debug_instruction_table[p->opcode].addr; -} -#endif - /* Scheme interface */ SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0, @@ -219,7 +194,7 @@ SCM_DEFINE (scm_instruction_name_p, "instruction-name?", 1, 0, 0, #define FUNC_NAME s_scm_instruction_name_p { SCM_VALIDATE_SYMBOL (1, name); - return SCM_BOOL (find_instruction_by_name (SCM_SYMBOL_CHARS (name))); + return SCM_BOOL (scm_lookup_instruction (SCM_SYMBOL_CHARS (name))); } #undef FUNC_NAME @@ -231,7 +206,7 @@ SCM_DEFINE (scm_symbol_to_instruction, "symbol->instruction", 1, 0, 0, struct scm_instruction *p; SCM_VALIDATE_SYMBOL (1, name); - p = find_instruction_by_name (SCM_SYMBOL_CHARS (name)); + p = scm_lookup_instruction (SCM_SYMBOL_CHARS (name)); if (!p) SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name)); @@ -246,7 +221,7 @@ SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, { SCM list = SCM_EOL; struct scm_instruction *p; - for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + for (p = scm_instruction_table; p->opcode != op_last; p++) list = scm_cons (p->obj, list); return scm_reverse_x (list, SCM_EOL); } @@ -338,7 +313,7 @@ mark_bytecode (SCM bytecode) for (i = 0; i < size; i++) { - p = find_instruction_by_code (base[i]); + p = SCM_INSTRUCTION (base[i]); switch (p->type) { case INST_NONE: @@ -472,9 +447,9 @@ SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0, /* Process instruction */ if (!SCM_SYMBOLP (old[i]) - || !(p = find_instruction_by_name (SCM_SYMBOL_CHARS (old[i])))) + || !(p = scm_lookup_instruction (SCM_SYMBOL_CHARS (old[i])))) SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old[i])); - new[i] = SCM_ADDR_TO_CODE (p->addr); + new[i] = SCM_PACK (p->opcode); /* Process arguments */ if (p->type == INST_NONE) @@ -543,7 +518,7 @@ SCM_DEFINE (scm_bytecode_decode, "bytecode-decode", 1, 0, 0, struct scm_instruction *p; /* Process instruction */ - p = find_instruction_by_code (old[i]); + p = SCM_INSTRUCTION (old[i]); if (!p) { broken: @@ -1010,7 +985,7 @@ SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 2, 0, 0, p = SCM_VM_ADDRESS (addr); - inst = find_instruction_by_code (*p); + inst = SCM_INSTRUCTION (*p); if (!inst) SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr)); @@ -1135,7 +1110,7 @@ SCM_SYMBOL (sym_debug, "debug"); static SCM scm_regular_vm (SCM vm, SCM program); static SCM scm_debug_vm (SCM vm, SCM program); -#define VM_CODE(name) SCM_ADDR_TO_CODE (find_instruction_by_name (name)->addr) +#define VM_CODE(name) SCM_PACK (scm_lookup_instruction (name)->opcode) SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0, (SCM vm, SCM program), @@ -1256,7 +1231,6 @@ scm_init_vm () /* Initialize the module */ scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)")); old_module = scm_select_module (scm_module_vm); - init_name_property (); init_instruction_type (); init_bytecode_type (); @@ -1264,37 +1238,15 @@ scm_init_vm () init_vm_frame_type (); init_vm_cont_type (); init_vm_type (); - #include "vm.x" - scm_select_module (old_module); - /* Initialize instruction tables */ { - int i; struct scm_instruction *p; - - SCM vm = make_vm (0); - scm_regular_vm (vm, SCM_BOOL_F); - scm_debug_vm (vm, SCM_BOOL_F); - - /* hash table */ - for (i = 0; i < INSTRUCTION_HASH_SIZE; i++) - scm_instruction_hash_table[i] = NULL; - - for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + for (p = scm_instruction_table; p->opcode != op_last; p++) { - int hash; - struct inst_hash *data; - SCM inst = scm_permanent_object (make_instruction (p)); - p->obj = inst; + p->obj = scm_permanent_object (make_instruction (p)); if (p->restp) p->type = INST_INUM; - hash = INSTRUCTION_HASH (p->addr); - data = scm_must_malloc (sizeof (*data), "inst_hash"); - data->addr = p->addr; - data->inst = p; - data->next = scm_instruction_hash_table[hash]; - scm_instruction_hash_table[hash] = data; } } } diff --git a/src/vm.h b/src/vm.h index 4de9a5039..a1320f1b3 100644 --- a/src/vm.h +++ b/src/vm.h @@ -51,9 +51,9 @@ /* Opcode */ enum scm_opcode { -#include "vm_system.op" -#include "vm_scheme.op" -#include "vm_number.op" +#include "vm_system.opcode" +#include "vm_scheme.opcode" +#include "vm_number.opcode" op_last }; @@ -73,7 +73,6 @@ struct scm_instruction { enum scm_opcode opcode; /* opcode */ enum scm_inst_type type; /* argument type */ char *name; /* instruction name */ - void *addr; /* instruction address */ SCM obj; /* instruction object */ /* fields for VM functions */ char *sname; /* Scheme procedure name */ diff --git a/src/vm_engine.c b/src/vm_engine.c index dbf68c534..9d459b17b 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -45,14 +45,11 @@ /* VM names */ #undef VM_NAME -#undef VM_TABLE #if VM_ENGINE == SCM_VM_REGULAR_ENGINE #define VM_NAME scm_regular_vm -#define VM_TABLE scm_regular_instruction_table #else #if VM_ENGINE == SCM_VM_DEBUG_ENGINE #define VM_NAME scm_debug_vm -#define VM_TABLE scm_debug_instruction_table #endif #endif @@ -79,20 +76,12 @@ VM_NAME (SCM vm, SCM program) SCM hook_args = SCM_LIST1 (vm); #endif - /* Initialize the instruction table at the first time. - * This code must be here because the following table contains - * pointers to the labels defined in this function. */ - if (!VM_TABLE) - { - static struct scm_instruction table[] = { -#include "vm_system.vi" -#include "vm_scheme.vi" -#include "vm_number.vi" - { op_last } - }; - VM_TABLE = table; - return SCM_UNSPECIFIED; - } + /* Jump talbe */ + static void *jump_table[] = { +#include "vm_system.label" +#include "vm_scheme.label" +#include "vm_number.label" + }; /* Initialize the VM */ vmp = SCM_VM_DATA (vm); diff --git a/src/vm_engine.h b/src/vm_engine.h index e8fb3cf88..151e5969c 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -348,11 +348,7 @@ #undef VM_GOTO_NEXT #if HAVE_LABELS_AS_VALUES -#if VM_ENGINE == SCM_VM_DEBUG_ENGINE -#define VM_GOTO_NEXT() goto *SCM_CODE_TO_DEBUG_ADDR (FETCH ()) -#else /* not SCM_VM_DEBUG_ENGINE */ -#define VM_GOTO_NEXT() goto *SCM_CODE_TO_ADDR (FETCH ()) -#endif +#define VM_GOTO_NEXT() goto *jump_table[SCM_UNPACK (FETCH ())] #else /* not HAVE_LABELS_AS_VALUES */ #define VM_GOTO_NEXT() goto vm_start #endif -- cgit v1.2.3 From 420971672755530445fb8001c4b3fcef34d7293f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 27 Sep 2000 23:41:10 +0000 Subject: *** empty log message *** --- ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ChangeLog b/ChangeLog index 5df9f6241..1b54e9913 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2000-09-27 Keisuke Nishida + + * src/vm.c, src/vm.h, src/vm_engine.c, src/vm_engine.h, + src/vm-snarf.h: Indirect threaded. + * src/Makefile.am, src/.cvsignore: Updated. + 2000-09-22 Keisuke Nishida * src/vm.c: SCM_CHARS -> SCM_SYMBOL_CHARS. -- cgit v1.2.3 From 77c04abec94a64484c38063255979e93ad2d93f1 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 29 Sep 2000 18:08:00 +0000 Subject: Create *.i from *.c and include them. --- src/Makefile.am | 23 ++++--------- src/vm-snarf.h | 102 -------------------------------------------------------- src/vm.c | 9 +++-- src/vm.h | 10 ++++-- src/vm_engine.c | 10 ++++-- src/vm_expand.h | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/vm_number.c | 2 -- src/vm_scheme.c | 2 -- src/vm_system.c | 2 -- 9 files changed, 119 insertions(+), 134 deletions(-) delete mode 100644 src/vm-snarf.h create mode 100644 src/vm_expand.h diff --git a/src/Makefile.am b/src/Makefile.am index c5b9b30b4..56b724975 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -8,12 +8,10 @@ bin_SCRIPTS = guile-compile lib_LTLIBRARIES = libguilevm.la libguilevm_la_SOURCES = vm.c libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic -noinst_HEADERS = vm.h vm_engine.h vm-snarf.h +noinst_HEADERS = vm.h vm_engine.h vm_expand.h EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c \ test.scm guile-compile.in -BUILT_SOURCES = vm_system.inst vm_scheme.inst vm_number.inst \ - vm_system.label vm_scheme.label vm_number.label \ - vm_system.opcode vm_scheme.opcode vm_number.opcode vm.x +BUILT_SOURCES = vm_system.i vm_scheme.i vm_number.i vm.x CFLAGS = -g -O2 -Wall INCLUDES = $(GUILE_CFLAGS) @@ -22,24 +20,15 @@ DISTCLEANFILES = $(BUILT_SOURCES) MAINTAINERCLEANFILES = Makefile.in config.h.in stamp-h.in SNARF = guile-snarf -SUFFIXES = .x .inst .label .opcode +SUFFIXES = .x .i .c.x: $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -.c.inst: - $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ - || { rm $@; false; } - -.c.label: - $(SNARF) -DSCM_SNARF_LABEL $(DEFS) $(INCLUDES) $(CPPFLAGS) \ - $(CFLAGS) $< > $@ || { rm $@; false; } - -.c.opcode: - $(SNARF) -DSCM_SNARF_OPCODE $(DEFS) $(INCLUDES) $(CPPFLAGS) \ - $(CFLAGS) $< > $@ || { rm $@; false; } +.c.i: + grep '^SCM_DEFINE' $< > $@ -$(BUILT_SOURCES): config.h vm-snarf.h +$(BUILT_SOURCES): config.h vm_expand.h guile-compile: guile-compile.in sed -e 's!\@bindir\@!$(bindir)!' -e 's!\@PACKAGE\@!$(PACKAGE)!' \ diff --git a/src/vm-snarf.h b/src/vm-snarf.h deleted file mode 100644 index 8e35ac1a3..000000000 --- a/src/vm-snarf.h +++ /dev/null @@ -1,102 +0,0 @@ -/* Copyright (C) 2000 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_SNARF_H -#define VM_SNARF_H - -#include "config.h" - -#define VM_LABEL(TAG) l_##TAG## -#define VM_OPCODE(TAG) 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 */ - -#ifndef SCM_MAGIC_SNARFER - -/* - * These are directly included in vm_engine.c - */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_TAG(TAG) -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_TAG(TAG) - -#else /* SCM_MAGIC_SNARFER */ -#ifndef SCM_SNARF_OPCODE -#ifndef SCM_SNARF_LABEL - -/* - * These will go to *.inst - */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ - SCM_SNARF_INIT_START {VM_OPCODE(TAG), TYPE, NAME, SCM_BOOL_F, NULL, 0, 0}, -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ - SCM_SNARF_INIT_START {VM_OPCODE(TAG), INST_NONE, NAME, SCM_BOOL_F, SNAME, NARGS, RESTP}, - -#else /* SCM_SNARF_LABEL */ - -/* - * These will go to *.label - */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ - SCM_SNARF_INIT_START VM_ADDR(TAG), -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ - SCM_SNARF_INIT_START VM_ADDR(TAG), - -#endif /* SCM_SNARF_LABEL */ -#else /* SCM_SNARF_OPCODE */ - -/* - * These will go to *.opcode - */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ - SCM_SNARF_INIT_START VM_OPCODE(TAG), -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ - SCM_SNARF_INIT_START VM_OPCODE(TAG), - -#endif /* SCM_SNARF_OPCODE */ -#endif /* SCM_MAGIC_SNARFER */ - -#endif /* not VM_SNARF_H */ diff --git a/src/vm.c b/src/vm.c index 43e554fff..a784fae0c 100644 --- a/src/vm.c +++ b/src/vm.c @@ -117,9 +117,12 @@ init_name_property () static long scm_instruction_tag; static struct scm_instruction scm_instruction_table[] = { -#include "vm_system.inst" -#include "vm_scheme.inst" -#include "vm_number.inst" +#define VM_INSTRUCTION_TO_TABLE +#include "vm_expand.h" +#include "vm_system.i" +#include "vm_scheme.i" +#include "vm_number.i" +#undef VM_INSTRUCTION_TO_TABLE {op_last} }; diff --git a/src/vm.h b/src/vm.h index a1320f1b3..80f82467a 100644 --- a/src/vm.h +++ b/src/vm.h @@ -43,6 +43,7 @@ #define VM_H #include +#include "config.h" /* @@ -51,9 +52,12 @@ /* Opcode */ enum scm_opcode { -#include "vm_system.opcode" -#include "vm_scheme.opcode" -#include "vm_number.opcode" +#define VM_INSTRUCTION_TO_OPCODE +#include "vm_expand.h" +#include "vm_system.i" +#include "vm_scheme.i" +#include "vm_number.i" +#undef VM_INSTRUCTION_TO_OPCODE op_last }; diff --git a/src/vm_engine.c b/src/vm_engine.c index 9d459b17b..ab68ce028 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -78,9 +78,12 @@ VM_NAME (SCM vm, SCM program) /* Jump talbe */ static void *jump_table[] = { -#include "vm_system.label" -#include "vm_scheme.label" -#include "vm_number.label" +#define VM_INSTRUCTION_TO_LABEL +#include "vm_expand.h" +#include "vm_system.i" +#include "vm_scheme.i" +#include "vm_number.i" +#undef VM_INSTRUCTION_TO_LABEL }; /* Initialize the VM */ @@ -101,6 +104,7 @@ VM_NAME (SCM vm, SCM program) vm_start: switch (*pc++) { #endif +#include "vm_expand.h" #include "vm_system.c" #include "vm_scheme.c" #include "vm_number.c" diff --git a/src/vm_expand.h b/src/vm_expand.h new file mode 100644 index 000000000..1eeea817e --- /dev/null +++ b/src/vm_expand.h @@ -0,0 +1,93 @@ +/* Copyright (C) 2000 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. */ + +#include "config.h" + +#ifndef VM_LABEL +#define VM_LABEL(TAG) l_##TAG## +#define VM_OPCODE(TAG) 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 SCM_DEFINE_INSTRUCTION +#undef SCM_DEFINE_VM_FUNCTION +#ifdef VM_INSTRUCTION_TO_TABLE +/* + * These will go to scm_instruction_table in vm.c + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ + {VM_OPCODE(TAG), TYPE, NAME, SCM_PACK (0), NULL, 0, 0}, +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ + {VM_OPCODE(TAG), INST_NONE, NAME, SCM_PACK (0), SNAME, NARGS, RESTP}, + +#else +#ifdef VM_INSTRUCTION_TO_LABEL +/* + * These will go to jump_table in vm_engine.c + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_ADDR(TAG), +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_ADDR(TAG), + +#else +#ifdef VM_INSTRUCTION_TO_OPCODE +/* + * These will go to scm_opcode in vm.h + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_OPCODE(TAG), +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_OPCODE(TAG), + +#else /* Otherwise */ +/* + * These are directly included in vm_engine.c + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_TAG(TAG) +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_TAG(TAG) + +#endif /* VM_INSTRUCTION_TO_OPCODE */ +#endif /* VM_INSTRUCTION_TO_LABEL */ +#endif /* VM_INSTRUCTION_TO_TABLE */ diff --git a/src/vm_number.c b/src/vm_number.c index de7d7dd20..cc7b63ad0 100644 --- a/src/vm_number.c +++ b/src/vm_number.c @@ -41,8 +41,6 @@ /* This file is included in vm_engine.c */ -#include "vm-snarf.h" - #define FUNC2(CFUNC,SFUNC) \ { \ VM_SETUP_ARGS2 (); \ diff --git a/src/vm_scheme.c b/src/vm_scheme.c index 3ab57f694..3b3c6e5ab 100644 --- a/src/vm_scheme.c +++ b/src/vm_scheme.c @@ -41,8 +41,6 @@ /* This file is included in vm_engine.c */ -#include "vm-snarf.h" - SCM_DEFINE_VM_FUNCTION (null_p, "null?", "null?", 1, 0) { VM_SETUP_ARGS1 (); diff --git a/src/vm_system.c b/src/vm_system.c index a7cd19380..de8041d96 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -41,8 +41,6 @@ /* This file is included in vm_engine.c */ -#include "vm-snarf.h" - /* * Variable access */ -- cgit v1.2.3 From a56b30ccd12a320b72b2fd25bd0ebe57acc77fc9 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 29 Sep 2000 18:08:19 +0000 Subject: *** empty log message *** --- ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index 1b54e9913..2cc408832 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2000-09-29 Keisuke Nishida + + * src/Makefile.am: Don't use guile-snarf to generate instruction + table. Create *.i by using grep. + * src/vm_expand.h: Replaced from vm-snarf.h. + * src/vm.c, src/vm.h, src/vm_engine.c: Include *.i. + * src/vm_system.c, src/vm_scheme.c, src/vm_number.c: Don't include + "vm-snarf.h". + 2000-09-27 Keisuke Nishida * src/vm.c, src/vm.h, src/vm_engine.c, src/vm_engine.h, -- cgit v1.2.3 From eef3cc8cdae33e27e64d0fcad6f8385f0ee3811d Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 6 Oct 2000 00:39:44 +0000 Subject: Use `values\' and `call-with-values\'. --- vm/compile.scm | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/vm/compile.scm b/vm/compile.scm index 9baf2a40c..cc7bc07cc 100644 --- a/vm/compile.scm +++ b/vm/compile.scm @@ -106,30 +106,29 @@ (make-code:constant env (car args))) (define (canon-formals formals) - ;; foo -> (() . foo) - ;; (foo bar baz) -> ((foo bar baz) . #f) - ;; (foo bar . baz) -> ((foo bar) . baz) + ;; foo -> (), foo + ;; (foo bar baz) -> (foo bar baz), #f + ;; (foo bar . baz) -> (foo bar), baz (cond ((symbol? formals) - (cons '() formals)) + (values '() formals)) ((or (null? formals) (null? (cdr (last-pair formals)))) - (cons formals #f)) + (values formals #f)) (else (let* ((copy (list-copy formals)) (pair (last-pair copy)) (last (cdr pair))) (set-cdr! pair '()) - (cons copy last))))) + (values copy last))))) (define (parse-lambda args env) (let ((formals (car args)) (body (cdr args))) - (let* ((pair (canon-formals formals)) - (reqs (car pair)) - (rest (cdr pair)) - (syms (append reqs (if rest (list rest) '()))) - (new-env (make-env syms env))) - (make-code:program env (length reqs) (if rest #t #f) - (parse-begin body new-env))))) + (call-with-values (lambda () (canon-formals formals)) + (lambda (reqs rest) + (let* ((syms (append reqs (if rest (list rest) '()))) + (new-env (make-env syms env))) + (make-code:program env (length reqs) (if rest #t #f) + (parse-begin body new-env))))))) (define (parse-set! args env) (let ((var (env-ref env (car args))) -- cgit v1.2.3 From d43c690f405262f24b0ad0ceaa9eedca5c4c6b07 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Fri, 6 Oct 2000 00:40:00 +0000 Subject: *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 2cc408832..42f3c41d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2000-10-05 Keisuke Nishida + + * vm/compile.scm (canon-formals): Use `values'. + (parse-lambda): Use `call-with-values'. + 2000-09-29 Keisuke Nishida * src/Makefile.am: Don't use guile-snarf to generate instruction -- cgit v1.2.3 From c092937bd5da5b3ca35fd7a7cc54538767fe6ab5 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 1 Apr 2001 04:57:52 +0000 Subject: *** empty log message *** --- test/.cvsignore | 4 ---- test/Makefile.am | 16 --------------- test/control.scm | 20 ------------------ test/procedure.scm | 60 ------------------------------------------------------ test/queens.scm | 50 --------------------------------------------- test/test.scm | 12 ----------- 6 files changed, 162 deletions(-) delete mode 100644 test/.cvsignore delete mode 100644 test/Makefile.am delete mode 100644 test/control.scm delete mode 100644 test/procedure.scm delete mode 100644 test/queens.scm delete mode 100644 test/test.scm diff --git a/test/.cvsignore b/test/.cvsignore deleted file mode 100644 index 3f4d1f06e..000000000 --- a/test/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -.cvsignore -Makefile -Makefile.in -*.scc diff --git a/test/Makefile.am b/test/Makefile.am deleted file mode 100644 index 87daf1f15..000000000 --- a/test/Makefile.am +++ /dev/null @@ -1,16 +0,0 @@ -SOURCE_FILES = control.scm procedure.scm queens.scm -COMPILED_FILES = control.scc procedure.scc queens.scc -EXTRA_DIST = test.scm $(SOURCE_FILES) -CLEANFILES = $(COMPILED_FILES) -MAINTAINERCLEANFILES = Makefile.in - -GUILE = $(top_srcdir)/src/$(PACKAGE) - -test: $(COMPILED_FILES) - @for file in $(COMPILED_FILES); do \ - $(GUILE) -s test.scm $$file; \ - done - -SUFFIXES = .scm .scc -.scm.scc: - guile-compile $< diff --git a/test/control.scm b/test/control.scm deleted file mode 100644 index 2ae9ee78a..000000000 --- a/test/control.scm +++ /dev/null @@ -1,20 +0,0 @@ - -(define income-tax - (lambda (income) - (cond - ((<= income 10000) - (* income .05)) - ((<= income 20000) - (+ (* (- income 10000) .08) - 500.00)) - ((<= income 30000) - (+ (* (- income 20000) .13) - 1300.00)) - (else - (+ (* (- income 30000) .21) - 2600.00))))) - -(test (income-tax 5000) 250.0) -(test (income-tax 15000) 900.0) -(test (income-tax 25000) 1950.0) -(test (income-tax 50000) 6800.0) diff --git a/test/procedure.scm b/test/procedure.scm deleted file mode 100644 index 5a25e59a9..000000000 --- a/test/procedure.scm +++ /dev/null @@ -1,60 +0,0 @@ -(define length - (lambda (ls) - (if (null? ls) - 0 - (+ (length (cdr ls)) 1)))) - -(test (length '()) 0) -(test (length '(a)) 1) -(test (length '(a b)) 2) - -(define remv - (lambda (x ls) - (cond - ((null? ls) '()) - ((eqv? (car ls) x) (remv x (cdr ls))) - (else (cons (car ls) (remv x (cdr ls))))))) - -(test (remv 'a '(a b b d)) '(b b d)) -(test (remv 'b '(a b b d)) '(a d)) -(test (remv 'c '(a b b d)) '(a b b d)) -(test (remv 'd '(a b b d)) '(a b b)) - -(define tree-copy - (lambda (tr) - (if (not (pair? tr)) - tr - (cons (tree-copy (car tr)) - (tree-copy (cdr tr)))))) - -(test (tree-copy '((a . b) . c)) '((a . b) . c)) - -(define quadratic-formula - (lambda (a b c) - (let ((root1 0) (root2 0) (minusb 0) (radical 0) (divisor 0)) - (set! minusb (- 0 b)) - (set! radical (sqrt (- (* b b) (* 4 (* a c))))) - (set! divisor (* 2 a)) - (set! root1 (/ (+ minusb radical) divisor)) - (set! root2 (/ (- minusb radical) divisor)) - (cons root1 root2)))) - -(test (quadratic-formula 2 -4 -6) '(3.0 . -1.0)) - -(define count - (let ((n 0)) - (lambda () - (set! n (1+ n)) - n))) - -(test (count) 1) -(test (count) 2) - -(define (fibonacci i) - (cond ((= i 0) 0) - ((= i 1) 1) - (else (+ (fibonacci (- i 1)) (fibonacci (- i 2)))))) - -(test (fibonacci 0) 0) -(test (fibonacci 5) 5) -(test (fibonacci 10) 55) diff --git a/test/queens.scm b/test/queens.scm deleted file mode 100644 index 66e8f0ce7..000000000 --- a/test/queens.scm +++ /dev/null @@ -1,50 +0,0 @@ -(define (filter predicate sequence) - (cond ((null? sequence) '()) - ((predicate (car sequence)) - (cons (car sequence) - (filter predicate (cdr sequence)))) - (else (filter predicate (cdr sequence))))) - -(define (accumulate op initial sequence) - (if (null? sequence) - initial - (op (car sequence) - (accumulate op initial (cdr sequence))))) - -(define (flatmap proc seq) - (accumulate append '() (map proc seq))) - -(define (enumerate-interval low high) - (if (> low high) - '() - (cons low (enumerate-interval (+ low 1) high)))) - -(define empty-board '()) - -(define (rest bs k rest-of-queens) - (map (lambda (new-row) - (adjoin-position new-row k rest-of-queens)) - (enumerate-interval 1 bs))) - -(define (queen-cols board-size k) - (if (= k 0) - (list empty-board) - (filter (lambda (positions) (safe? k positions)) - (flatmap (lambda (r) (rest board-size k r)) - (queen-cols board-size (- k 1)))))) - -(define (queens board-size) - (queen-cols board-size board-size)) - -(define (adjoin-position new-row k rest-of-queens) - (append rest-of-queens (list new-row))) - -(define (safe? k positions) - (let ((new (car (last-pair positions))) - (bottom (car positions))) - (cond ((= k 1) #t) - ((= new bottom) #f) - ((or (= new (- bottom (- k 1))) (= new (+ bottom (- k 1)))) #f) - (else (safe? (- k 1) (cdr positions)))))) - -(test (queens 4) '((2 4 1 3) (3 1 4 2))) diff --git a/test/test.scm b/test/test.scm deleted file mode 100644 index fd08af322..000000000 --- a/test/test.scm +++ /dev/null @@ -1,12 +0,0 @@ - -(set! %load-path (cons ".." %load-path)) -(use-modules (vm vm)) - -(define (test a b) - (if (equal? a b) - (display "OK\n") - (display "failed\n"))) - -(let ((file (cadr (command-line)))) - (format #t "Testing ~S...\n" file) - (load file)) -- cgit v1.2.3 From 17e90c5e25a7a2e453742044ee6a3fa5f27e9e5d Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 1 Apr 2001 05:03:41 +0000 Subject: New VM. --- .cvsignore | 2 +- ChangeLog | 108 ---- Makefile.am | 2 +- THANKS | 2 +- configure.in | 4 +- module/.cvsignore | 2 + module/Makefile.am | 13 + module/language/ghil/GPKG.def | 8 + module/language/ghil/spec.scm | 31 + module/system/base/language.scm | 111 ++++ module/system/base/module.scm | 222 +++++++ module/system/base/syntax.scm | 98 +++ module/system/il/compile.scm | 196 ++++++ module/system/il/ghil.scm | 266 +++++++++ module/system/il/glil.scm | 184 ++++++ module/system/il/macros.scm | 435 ++++++++++++++ module/system/repl/command.scm | 506 ++++++++++++++++ module/system/repl/common.scm | 93 +++ module/system/repl/describe.scm | 364 +++++++++++ module/system/repl/repl.scm | 74 +++ module/system/vm/assemble.scm | 327 ++++++++++ module/system/vm/conv.scm | 137 +++++ module/system/vm/core.scm | 35 ++ module/system/vm/disasm.scm | 118 ++++ module/system/vm/frame.scm | 32 + module/system/vm/profile.scm | 66 ++ module/system/vm/trace.scm | 75 +++ src/.cvsignore | 6 +- src/Makefile.am | 36 +- src/envs.c | 250 ++++++++ src/envs.h | 73 +++ src/guile-compile.in | 6 - src/guile-vm.c | 12 +- src/instructions.c | 138 +++++ src/instructions.h | 84 +++ src/programs.c | 209 +++++++ src/programs.h | 94 +++ src/test.scm | 60 -- src/vm.c | 1260 ++++++++++----------------------------- src/vm.h | 242 +++----- src/vm_engine.c | 122 ++-- src/vm_engine.h | 458 +++++++------- src/vm_expand.h | 42 +- src/vm_loader.c | 133 +++++ src/vm_number.c | 200 +++---- src/vm_scheme.c | 113 ++-- src/vm_system.c | 579 +++++++++--------- 47 files changed, 5534 insertions(+), 2094 deletions(-) create mode 100644 module/.cvsignore create mode 100644 module/Makefile.am create mode 100644 module/language/ghil/GPKG.def create mode 100644 module/language/ghil/spec.scm create mode 100644 module/system/base/language.scm create mode 100644 module/system/base/module.scm create mode 100644 module/system/base/syntax.scm create mode 100644 module/system/il/compile.scm create mode 100644 module/system/il/ghil.scm create mode 100644 module/system/il/glil.scm create mode 100644 module/system/il/macros.scm create mode 100644 module/system/repl/command.scm create mode 100644 module/system/repl/common.scm create mode 100644 module/system/repl/describe.scm create mode 100644 module/system/repl/repl.scm create mode 100644 module/system/vm/assemble.scm create mode 100644 module/system/vm/conv.scm create mode 100644 module/system/vm/core.scm create mode 100644 module/system/vm/disasm.scm create mode 100644 module/system/vm/frame.scm create mode 100644 module/system/vm/profile.scm create mode 100644 module/system/vm/trace.scm create mode 100644 src/envs.c create mode 100644 src/envs.h delete mode 100644 src/guile-compile.in create mode 100644 src/instructions.c create mode 100644 src/instructions.h create mode 100644 src/programs.c create mode 100644 src/programs.h delete mode 100644 src/test.scm create mode 100644 src/vm_loader.c diff --git a/.cvsignore b/.cvsignore index 5b27a2a54..92045d53c 100644 --- a/.cvsignore +++ b/.cvsignore @@ -1,4 +1,4 @@ -.cvsignore +misc libtool config.log config.cache diff --git a/ChangeLog b/ChangeLog index 42f3c41d7..56b451d7b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,111 +1,3 @@ -2000-10-05 Keisuke Nishida - - * vm/compile.scm (canon-formals): Use `values'. - (parse-lambda): Use `call-with-values'. - -2000-09-29 Keisuke Nishida - - * src/Makefile.am: Don't use guile-snarf to generate instruction - table. Create *.i by using grep. - * src/vm_expand.h: Replaced from vm-snarf.h. - * src/vm.c, src/vm.h, src/vm_engine.c: Include *.i. - * src/vm_system.c, src/vm_scheme.c, src/vm_number.c: Don't include - "vm-snarf.h". - -2000-09-27 Keisuke Nishida - - * src/vm.c, src/vm.h, src/vm_engine.c, src/vm_engine.h, - src/vm-snarf.h: Indirect threaded. - * src/Makefile.am, src/.cvsignore: Updated. - -2000-09-22 Keisuke Nishida - - * src/vm.c: SCM_CHARS -> SCM_SYMBOL_CHARS. - -2000-09-22 Keisuke Nishida - - * src/vm_system.c (call): Call return-hook before reinstating a - continuation. - (tail_call): Call return-hook before a proper tail call. - -2000-09-20 Keisuke Nishida - - * src/vm.c (scm_name_property): New variable. - (scm_name, scm_set_name_x): New procedures. - (scm_smob_print_with_name, init_name_property): New functions. - (print_program, scm_program_name): Removed. - (init_program_type, init_vm_type): Use scm_smob_print_with_name. - (scm_init_vm): Call init_name_property. - * src/vm_system.c (name): New instruction. - (savet): Don't set name. - * vm/shell.scm (vm-frame->call): Updated. - * vm/bytecomp.scm (translate-ref): Combined translate-local-ref, - translate-external-ref, and translate-top-level-ref. - (translate-set): Combined translate-local-set, - translate-external-set, and translate-top-level-ref. - Set a name to the object. - - * src/vm_number.c (FUNC2): New macro. - (add2, sub2): Use FUNC2. - (remainder): New instruction. - - * vm/bytecomp.scm (translate-and, translate-or): Bug fixed. - -2000-09-20 Keisuke Nishida - - * src/vm_scheme.c (cons): Bug fixed. - * src/vm_system.c (br_if_null): Set ac = SCM_BOOL_T if null. - (br_if_not_null): Set ac = SCM_BOOL_F if not null. - -2000-09-11 Keisuke Nishida - - * autogen.sh: Run aclocal with check where guile.m4 is installed. - -2000-09-10 Keisuke Nishida - - * src/vm_system.c (push_list): New instruction. - * src/vm_engine.c (VM_NAME): Don't validate VM and PROGRAM. - * src/vm.c (scm_vm_apply): New procedure. - (apply_program): New function. - (init_program_type): Set the apply function for the program type. - - * src/vm.c (lookup_variable): Use scm_eval_closure_lookup. - -2000-09-03 Keisuke Nishida - - * src/vm_system.c (tail_call): Use SCM_TICK at the beginning. - -2000-09-02 Keisuke Nishida - - * src/vm_engine.c (VM_NAME): Renamed the variable `an' to `nargs'. - Removed the variables `a2' and `a3'. - * src/vm_engine.h (VM_SETUP_ARGS2, VM_SETUP_ARGS3): Setup local - variables. - (VM_SETUP_ARGS4): Removed. - * src/vm_system.c, src/vm_scheme.c, src/vm_number.c: Updated. - -2000-08-24 Keisuke Nishida - - * src/vm.c (lookup_variable): New function. - (scm_make_bytecode): Call lookup_variable for top-level variables. - * src/vm_engine.h (VM_VARIABLE_REF, VM_VARIABLE_SET): New macros. - * src/vm_system.c (TOPLEVEL_VAR, TOPLEVEL_VAR_SET): Removed. - Use VM_VARIABLE_REF and VM_VARIABLE_SET instead. - -2000-08-22 Keisuke Nishida - - * src/vm.c, src/vm.h, src/vm_engine.c, src/vm_engine.h, - src/vm_system.c: Create external frames dynamically. - * vm/shell.scm: Use frame-external-link. - - * vm/compile.scm (compile-file): Output "(use-modules (vm vm))". - - * vm/types.scm (make-code): Check argument types. - (make-code:and, make-code:or): Pass env to make-code. - - * vm/bytecomp.scm (translate-and, translate-or): Don't branch on - the last expression. - 2000-08-20 Keisuke Nishida * Version 0.2 is released. diff --git a/Makefile.am b/Makefile.am index e38d314b0..1b0e4dd45 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,4 +1,4 @@ -SUBDIRS = src vm doc test +SUBDIRS = src doc module EXTRA_DIST = acconfig.h diff --git a/THANKS b/THANKS index da16a3a50..507d4ec00 100644 --- a/THANKS +++ b/THANKS @@ -1 +1 @@ -Guile VM is motivated by QScheme. +Guile VM was motivated by QScheme and librep. diff --git a/configure.in b/configure.in index d0f58bb29..eda04c472 100644 --- a/configure.in +++ b/configure.in @@ -1,5 +1,5 @@ AC_INIT(src/guile-vm.c) -AM_INIT_AUTOMAKE(guile-vm, 0.2) +AM_INIT_AUTOMAKE(guile-vm, 0.3) AM_CONFIG_HEADER(src/config.h) GUILE_FLAGS @@ -12,4 +12,4 @@ AC_PROG_LN_S AM_PROG_LIBTOOL AC_C_LABELS_AS_VALUES -AC_OUTPUT(Makefile src/Makefile vm/Makefile doc/Makefile test/Makefile) +AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile) diff --git a/module/.cvsignore b/module/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/module/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/module/Makefile.am b/module/Makefile.am new file mode 100644 index 000000000..aa748128e --- /dev/null +++ b/module/Makefile.am @@ -0,0 +1,13 @@ +guiledatadir = $(datadir)/guile + +install-data-local: + $(mkinstalldirs) $(DESTDIR)$(guiledatadir) + cp -rp module/* $(DESTDIR)$(guiledatadir) + rm -f $(guiledatadir)/system/vm/libcore.so \ + && $(LN_S) $(libdir)/libguilevm.so $(guiledatadir)/system/vm/libcore.so + +install-data-local: + $(mkinstalldirs) $(DESTDIR)$(guiledatadir) + cp -rp module/* $(DESTDIR)$(guiledatadir) + rm -f $(guiledatadir)/system/vm/libcore.so \ + && $(LN_S) $(libdir)/libguilevm.so $(guiledatadir)/system/vm/libcore.so diff --git a/module/language/ghil/GPKG.def b/module/language/ghil/GPKG.def new file mode 100644 index 000000000..999d2ef88 --- /dev/null +++ b/module/language/ghil/GPKG.def @@ -0,0 +1,8 @@ +;;; GHIL package definition -*- gscheme -*- + +(define-package ghil + :category Language + :version "0.3" + :author "Keisuke Nishida " + :modules ((spec "spec.scm" gscheme)) + ) diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm new file mode 100644 index 000000000..cfd6222e1 --- /dev/null +++ b/module/language/ghil/spec.scm @@ -0,0 +1,31 @@ +;;; Guile High Intermediate Language + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; Guile VM 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 VM 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 VM; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(define-module (language ghil spec) + :use-module (system base language) + :use-module (system base module) + :export (ghil)) + +(define-language ghil + :title "Guile High Intermediate Language (GHIL)" + :version "0.3" + :reader read + :printer write + :environment (make-vmodule) + ) diff --git a/module/system/base/language.scm b/module/system/base/language.scm new file mode 100644 index 000000000..c979d5cef --- /dev/null +++ b/module/system/base/language.scm @@ -0,0 +1,111 @@ +;;; 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 (oop goops) + :use-syntax (system base syntax) + :use-module (system base module) + :use-module (system il compile) + :use-module (system vm assemble) + :use-module (ice-9 regex) + :export (define-language lookup-language + read-in compile-in print-in compile-file-in load-file-in)) + + +;;; +;;; Language class +;;; + +(define-vm-class () + name title version environment + (reader) + (expander (lambda (x) x)) + (translator (lambda (x) x)) + (evaler #f) + (printer) + ) + +(define-method (write (lang ) port) + (display "#")) + +(define-macro (define-language name . spec) + `(define ,name (,make , :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)))) + + +;;; +;;; Evaluation interface +;;; + +(define (read-in lang . port) + (lang.reader (if (null? port) (current-input-port) (car port)))) + +(define (compile-in form env lang . opts) + (catch 'result + (lambda () + ;; expand + (set! form (lang.expander form)) + (if (memq :e opts) (throw 'result form)) + ;; translate + (set! form (lang.translator form)) + (if (memq :t opts) (throw 'result form)) + ;; compile + (set! form (apply compile form env opts)) + (if (memq :c opts) (throw 'result form)) + ;; assemble + (apply assemble form env opts)) + (lambda (key val) val))) + +(define (print-in val lang . port) + (lang.printer val (if (null? port) (current-output-port) (car port)))) + +(define (compile-file-in file env lang . opts) + (let* ((code (call-with-input-file file + (lambda (in) + (do ((x (read-in lang in) (read-in lang in)) + (l '() (cons (lang.translator (lang.expander x)) l))) + ((eof-object? x) (reverse! l)))))) + (asm (apply compile (cons '@begin code) env opts)) + (bytes (apply assemble asm env opts))) + (call-with-output-file (object-file-name file) + (lambda (out) (uniform-vector-write bytes out))))) + +(define (load-file-in file env lang) + (let ((compiled (object-file-name file))) + (if (or (not (file-exists? compiled)) + (> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) + (compile-file-in file env lang)) + (call-with-input-file compiled + (lambda (p) + (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a))) + (uniform-vector-read! bytes p) + bytes))))) + +(define (object-file-name file) + (let ((m (string-match "\\.[^.]*$" file))) + (string-append (if m (match:prefix m) file) ".go"))) diff --git a/module/system/base/module.scm b/module/system/base/module.scm new file mode 100644 index 000000000..99cc0ec7b --- /dev/null +++ b/module/system/base/module.scm @@ -0,0 +1,222 @@ +;;; Module system + +;; 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 module) + :use-module (oop goops) + :use-syntax (system base syntax) + :use-module (system base language) + :use-module (ice-9 regex) + :use-module (ice-9 common-list)) + +(define (expand-file-name file dir) + (string-append dir "/" file)) + + +;;; +;;; Environment +;;; + +(dynamic-call "scm_init_envs" (dynamic-link "libguilevm.so")) + +(export env-identifier) +(define-generic env-identifier) +(define-generic env-bound?) +(define-generic env-ref) +(define-generic env-set!) +(define-generic env-define) + +(export global-ref) + +(define (global-ref identifier) + (let loop ((e *root-package*) (l (identifier->list identifier))) + (cond ((null? l) e) + (else (loop (env-ref e (car l)) (cdr l)))))) + +(define (load-env identifier) + (let ((x (global-ref identifier))) x.env)) + +(define (identifier->list identifier) + (let loop ((s (symbol->string identifier)) (l '())) + (let ((m (string-match "::" s))) + (if m + (loop (match:suffix m) (cons (string->symbol (match:prefix m)) l)) + (reverse! (cons (string->symbol s) l)))))) + +(define-public (identifier-split identifier) + (let ((m (string-match "::([^:]*)$" (symbol->string identifier)))) + (if m + (values (string->symbol (match:prefix m)) + (string->symbol (match:substring m 1))) + (values #f identifier)))) + + +;;; +;;; Modules +;;; + +(define-vm-class () + (env (make-env)) + (bootcode)) + +(export make-vmodule) + +(define (make-vmodule) + (make )) + +(define-method (env-identifier (m )) + (env-identifier m.env)) + +(define-method (env-define (m ) (s ) v) + (env-define m.env s v)) + + +;;; +;;; Packages +;;; + +(define *package-def* "GPKG.def") + +(define-vm-class () + (env (make-env))) + +(define-method (env-bound? (p ) (s )) + (if (not (env-bound? p.env s)) + (cond ((package-lookup p s) => (lambda (v) (env-define p.env s v) #t)) + (else #f)))) + +(define-method (env-ref (p ) (s )) + (env-bound? p s) + (env-ref p.env s)) + +(define-method (env-define (p ) (s ) (c )) + (env-define p.env s c) + (let ((id (cond ((env-identifier p.env) => + (lambda (id) + (string->symbol (format #f "~A::~A" id s)))) + (else s)))) + (set-env-identifier! c.env id))) + +(define (try-load-package dir) + (if (and (file-exists? dir) (file-is-directory? dir)) + (if (file-exists? (expand-file-name *package-def* dir)) + (make-custom-package dir) + (make-plain-package dir)) + #f)) + +;; plain package + +(define-vm-class () + directory) + +(define (make-plain-package dir) + (make :directory dir)) + +(define-method (package-lookup (p ) (s )) + (let ((file (expand-file-name (string-downcase! (symbol->string s)) + p.directory))) + (or (try-load-package file) + (try-load-vmodule file)))) + +(define (try-load-vmodule file) + (or (try-load-compiled-vmodule file) + (try-load-source-vmodule file))) + +(define (try-load-compiled-vmodule file) #f) + +(define (try-load-source-vmodule file) #f) + +;; custom package + +(define-vm-class () + directory name category version author modules) + +(define (make-custom-package dir) + (call-with-input-file (expand-file-name *package-def* dir) + (lambda (p) + (apply make :directory dir :name (cdr (read p)))))) + +(define-method (package-lookup (p ) (s )) + (and-let* ((entry (assq-ref p.modules s))) + (let ((module (make-vmodule))) + (env-define p s module) + (let* ((file (expand-file-name (car entry) p.directory)) + (code (load-file-in file module (lookup-language (cadr entry))))) + (set! module.bootcode code)) + module))) + +;; multi package + +(define-vm-class () + packages) + +(define (make-multi-package dirs) + (let ((packages (pick id (map try-load-package dirs)))) + (make :packages packages))) + +(define-method (package-lookup (p ) (s )) + (list-fold (lambda (p d) + (let ((c (and (env-bound? p s) (env-ref p s)))) + (if c (if d (error "Module name conflict" d c) c) d))) + #f p.packages)) + + +;;; +;;; Guile old module +;;; + +(define (import-old-module! m module) + (hash-fold (lambda (k v d) (env-define m k (variable-ref v))) + #f (module-obarray module))) + + +;;; +;;; Current modules +;;; + +(export current-vmodule set-current-vmodule! + current-evaluator set-current-evaluator!) + +(define *current-module* #f) +(define (current-vmodule) *current-module*) +(define (set-current-vmodule! m) (set! *current-module* m)) + +(define *current-evaluator* #f) +(define (current-evaluator) *current-evaluator*) +(define (set-current-evaluator! e) (set! *current-evaluator* e)) + + +;;; +;;; Standard modules/packages +;;; + +(define *root-package* + (make-multi-package '("/usr/local/share/guile/site"))) + +(let ((user (make-vmodule))) + (env-define *root-package* 'user user)) + +(let ((core (make-vmodule))) + (env-define *root-package* 'core core) + (hash-fold (lambda (s v d) (env-define core s v)) #f (builtin-bindings))) + +(let ((module (make-vmodule))) + (env-define (global-ref 'System::Base) 'module module) + (import-old-module! module (current-module))) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm new file mode 100644 index 000000000..fab3f0bd0 --- /dev/null +++ b/module/system/base/syntax.scm @@ -0,0 +1,98 @@ +;;; 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) + :use-module (oop goops) + :use-module (ice-9 match) + :use-module (ice-9 receive) + :use-module (ice-9 and-let-star) + :export (match and-let* receive)) + + +;;; +;;; Keywords by `:KEYWORD' +;;; + +(read-set! keywords 'prefix) + + +;;; +;;; Dot expansion +;;; + +;; FOO.BAR -> (slot FOO 'BAR) + +(define (expand-dot! x) + (cond ((and (symbol? x) (not (eq? x '...))) (expand-symbol x)) + ((pair? x) + (cond ((memq (car x) '(quote quasiquote)) x) + (else (set-car! x (expand-dot! (car x))) + (set-cdr! x (expand-dot! (cdr x))) + x))) + (else x))) + +(define (expand-symbol x) + (let loop ((s (symbol->string x))) + (let ((i (string-rindex s #\.))) + (if i + `(slot ,(loop (substring s 0 i)) + (quote ,(string->symbol (substring s (1+ i))))) + (string->symbol s))))) + +(define syntax expand-dot!) +(export-syntax syntax) + +;; slot accessor +(define slot (make-procedure-with-setter slot-ref slot-set!)) +(export slot) + + +;;; +;;; Simplified define-class +;;; + +;; (define-vm-class () (x 1) (y 2)) => +;; +;; (define-class () +;; (a :init-keyword :a :init-form 1) +;; (b :init-keyword :b :init-form 2)) + +(define-macro (define-vm-class name supers . rest) + `(define-class ,name ,supers + ,@(map (lambda (def) + (if (not (pair? def)) (set! def (list def))) + (let ((name (car def)) (rest (cdr def))) + (cons* name :init-keyword (symbol->keyword name) + (if (or (null? rest) (keyword? (car rest))) + rest + (cons :init-form rest))))) + rest))) + +(export-syntax define-vm-class) + +;;; +;;; Other utilities +;;; + +(define-public (list-fold f d l) + (if (null? l) + d + (list-fold f (f (car l) d) (cdr l)))) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm new file mode 100644 index 000000000..fa73486e6 --- /dev/null +++ b/module/system/il/compile.scm @@ -0,0 +1,196 @@ +;;; GHIL -> GLIL compiler + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (system il compile) + :use-module (oop goops) + :use-syntax (system base syntax) + :use-module (system base module) + :use-module (system il glil) + :use-module (system il ghil) + :use-module (ice-9 common-list) + :export (compile)) + +(define (compile x e . opts) + (set! x (parse-ghil x e)) + (if (memq :O opts) (set! x (optimize x))) + (codegen x)) + + +;;; +;;; Stage 2: Optimization +;;; + +(define (optimize x) + (match x + (($ proc args) + (match proc + ;; ((@lambda (VAR...) BODY...) ARG...) => + ;; (@let ((VAR ARG) ...) BODY...) + (($ env vars #f body) + (optimize (make- vars args body))) + (else + (make- (optimize proc) (for-each optimize args))))) + (else x))) + + +;;; +;;; Stage 3: Code generation +;;; + +(define *ia-void* (make-)) +(define *ia-drop* (make- 'drop)) +(define *ia-return* (make- 'return)) + +(define (make-label) (gensym ":L")) + +(define (make-glil-var op env var) + (case var.kind + ((argument) + (make- op var.index)) + ((local) + (make- op var.index)) + ((external) + (do ((depth 0 (1+ depth)) + (e env e.parent)) + ((eq? e var.env) + (make- op depth var.index)))) + ((module) + (make- op var.env var.name)) + (else (error "Unknown kind of variable:" var)))) + +(define (codegen ghil) + (let ((stack '())) + (define (push-code! code) + (set! stack (cons code stack))) + (define (comp tree tail drop) + ;; 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)) + ;; return this code if necessary + (define (return-code! code) + (if (not drop) (push-code! code)) + (if tail (push-code! *ia-return*))) + ;; return void if necessary + (define (return-void!) (return-code! *ia-void*)) + ;; + ;; dispatch + (match tree + (($ ) + (return-void!)) + + (($ obj) + (return-code! (make- obj))) + + (($ env var) + (return-code! (make-glil-var 'ref env var))) + + (($ env var val) + (comp-push val) + (push-code! (make-glil-var 'set env var)) + (return-void!)) + + (($ test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (jump L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (push-code! (make- 'br-if-not L1)) + (comp-tail then) + (if (not tail) (push-code! (make- L2))) + (push-code! (make- L1)) + (comp-tail else) + (if (not tail) (push-code! (make- L2))))) + + (($ exps) + ;; EXPS... + ;; TAIL + (if (null? exps) + (return-void!) + (do ((exps exps (cdr exps))) + ((null? (cdr exps)) + (comp-tail (car exps))) + (comp-drop (car exps))))) + + (($ env vars vals body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (for-each comp-push vals) + (for-each (lambda (var) (push-code! (make-glil-var 'set env var))) + (reverse vars)) + (comp-tail body)) + + (($ vars rest body) + (return-code! (codegen tree))) + + (($ proc args) + ;; ARGS... + ;; PROC + ;; ([tail-]call NARGS) + (for-each comp-push args) + (comp-push proc) + (let ((inst (if tail 'tail-call 'call))) + (push-code! (make- inst (length args)))) + (if drop (push-code! *ia-drop*))) + + (($ inst args) + ;; ARGS... + ;; (INST) + (for-each comp-push args) + (push-code! (make- inst)) + (if drop (push-code! *ia-drop*)) + (if tail (push-code! *ia-return*))))) + ;; + ;; main + (match ghil + (($ env args rest body) + (let* ((vars env.variables) + (locs (pick (lambda (v) (eq? v.kind 'local)) vars)) + (exts (pick (lambda (v) (eq? v.kind 'external)) vars))) + ;; initialize variable indexes + (finalize-index! args) + (finalize-index! locs) + (finalize-index! exts) + ;; export arguments + (do ((n 0 (1+ n)) (l args (cdr l))) + ((null? l)) + (let ((v (car l))) + (if (eq? v.kind 'external) + (begin (push-code! (make- 'ref n)) + (push-code! (make- 'set 0 v.index)))))) + ;; compile body + (comp body #t #f) + ;; create GLIL + (make- (length args) (if rest 1 0) (length locs) + (length exts) (reverse! stack))))))) + +(define (finalize-index! list) + (do ((n 0 (1+ n)) + (l list (cdr l))) + ((null? l)) + (let ((v (car l))) (set! v.index n)))) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm new file mode 100644 index 000000000..9fdcf97fa --- /dev/null +++ b/module/system/il/ghil.scm @@ -0,0 +1,266 @@ +;;; Guile High Intermediate Language + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (system il ghil) + :use-module (oop goops) + :use-syntax (system base syntax) + :use-module (system base module) + :use-module (ice-9 match) + :use-module (ice-9 regex) + :export + (parse-ghil + make- ? + make- ? -1 + make- ? -1 -2 + make- ? -1 -2 -3 + make- ? -1 -2 -3 + make- ? -1 + make- ? + -1 -2 -3 -4 + make- ? + -1 -2 -3 -4 + make- ? -1 -2 + make- ? -1 -2 + )) + + +;;; +;;; Parse tree +;;; + +(define-structure ()) +(define-structure ( obj)) +(define-structure ( env var)) +(define-structure ( env var val)) +(define-structure ( test then else)) +(define-structure ( exps)) +(define-structure ( env vars vals body)) +(define-structure ( env args rest body)) +(define-structure ( proc args)) +(define-structure ( inst args)) + + +;;; +;;; Variables +;;; + +(define-vm-class () + env name kind type value index) + +(define (make-ghil-var env name kind) + (make :env env :name name :kind kind)) + + +;;; +;;; Modules +;;; + +(define-vm-class () + (module) + (table '()) + (imports '())) + +(define (make-ghil-mod module) + (make :module module)) + +(define-method (ghil-lookup (mod ) (sym )) + (or (assq-ref mod.table sym) + (let ((var (make-ghil-var (env-identifier mod.module) sym 'module))) + (set! mod.table (acons sym var mod.table)) + var))) + + +;;; +;;; Environments +;;; + +(define-vm-class () + (mod) + (parent #f) + (table '()) + (variables '())) + +(define-method (make-ghil-env (m )) + (make :mod m :parent m)) + +(define-method (make-ghil-env (e )) + (make :mod e.mod :parent e)) + +(define-method (ghil-env-ref (env ) (sym )) + (assq-ref env.table sym)) + +(define-method (ghil-env-add! (env ) (sym ) kind) + (let ((var (make-ghil-var env sym kind))) + (set! env.table (acons sym var env.table)) + (set! env.variables (cons var env.variables)) + var)) + +(define-method (ghil-env-remove! (env ) (sym )) + (set! env.table (assq-remove! env.table sym))) + +(define-method (ghil-lookup (env ) (sym )) + (or (ghil-env-ref env sym) + (let loop ((e env.parent)) + (cond ((is-a? e ) (ghil-lookup e sym)) + ((ghil-env-ref e sym) => + (lambda (var) (set! var.kind 'external) var)) + (else (loop e.parent)))))) + + +;;; +;;; Parser +;;; + +(define (parse-ghil x e) + (parse `(@lambda () ,x) (make-ghil-mod e))) + +(define (parse x e) + (cond ((pair? x) (parse-pair x e)) + ((symbol? x) + (let ((str (symbol->string x))) + (case (string-ref str 0) + ((#\@) (error "Invalid use of IL primitive" x)) + ((#\:) (let ((sym (string->symbol (substring str 1)))) + (make- (symbol->keyword sym)))) + (else (make- e (ghil-lookup e x)))))) + (else (make- x)))) + +(define (map-parse x e) + (map (lambda (x) (parse x e)) x)) + +(define *macros* (resolve-module '(system il macros))) + +(define (parse-pair x e) + (let ((head (car x)) (tail (cdr x))) + (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@)) + (if (module-defined? *macros* head) + (parse (apply (module-ref *macros* head) tail) e) + (parse-primitive head tail e)) + (make- (parse head e) (map-parse tail e))))) + +(define (parse-primitive prim args e) + (case prim + ;; (@ IDENTIFIER) + ((@) + (match args + (() + (make- e (make-ghil-var '@ '@ 'module))) + ((identifier) + (receive (module name) (identifier-split identifier) + (make- e (make-ghil-var module name 'module)))))) + + ;; (@@ INST ARGS...) + ((@@) + (match args + ((inst . args) + (make- inst (map-parse args e))))) + + ;; (@void) + ((@void) + (match args + (() (make-)))) + + ;; (@quote OBJ) + ((@quote) + (match args + ((obj) + (make- obj)))) + + ;; (@define NAME VAL) + ((@define) + (match args + ((name val) + (let ((v (ghil-lookup e name))) + (make- e v (parse val e)))))) + + ;; (@set! NAME VAL) + ((@set!) + (match args + ((name val) + (let ((v (ghil-lookup e name))) + (make- e v (parse val e)))))) + + ;; (@if TEST THEN [ELSE]) + ((@if) + (match args + ((test then) + (make- (parse test e) (parse then e) (make-))) + ((test then else) + (make- (parse test e) (parse then e) (parse else e))))) + + ;; (@begin BODY...) + ((@begin) + (parse-body args e)) + + ;; (@let ((SYM INIT)...) BODY...) + ((@let) + (match args + ((((sym init) ...) body ...) + (let* ((vals (map-parse init e)) + (vars (map (lambda (s) (ghil-env-add! e s 'local)) sym)) + (body (parse-body body e))) + (for-each (lambda (s) (ghil-env-remove! e s)) sym) + (make- e vars vals body))))) + + ;; (@letrec ((SYM INIT)...) BODY...) + ((@letrec) + (match args + ((((sym init) ...) body ...) + (let* ((vars (map (lambda (s) (ghil-env-add! e s 'local)) sym)) + (vals (map-parse init e)) + (body (parse-body body e))) + (for-each (lambda (s) (ghil-env-remove! e s)) sym) + (make- e vars vals body))))) + + ;; (@lambda FORMALS BODY...) + ((@lambda) + (match args + ((formals . body) + (receive (syms rest) (parse-formals formals) + (let* ((e (make-ghil-env e)) + (args (map (lambda (s) (ghil-env-add! e s 'argument)) syms))) + (make- e args rest (parse-body body e))))))) + + (else (error "Unknown primitive:" prim)))) + +(define (parse-body x e) + (make- (map-parse x e))) + +(define (parse-formals formals) + (cond + ;; (@lambda x ...) + ((symbol? formals) (values (list formals) #t)) + ;; (@lambda (x y z) ...) + ((list? formals) (values formals #f)) + ;; (@lambda (x y . z) ...) + ((pair? formals) + (let loop ((l formals) (v '())) + (if (pair? l) + (loop (cdr l) (cons (car l) v)) + (values (reverse! (cons l v)) #t)))) + (else (error "Invalid formals:" formals)))) + +(define (identifier-split identifier) + (let ((m (string-match "::([^:]*)$" (symbol->string identifier)))) + (if m + (values (string->symbol (match:prefix m)) + (string->symbol (match:substring m 1))) + (values #f identifier)))) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm new file mode 100644 index 000000000..f9eaba9b0 --- /dev/null +++ b/module/system/il/glil.scm @@ -0,0 +1,184 @@ +;;; Guile Low Intermediate Language + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (system il glil) + :use-module (ice-9 match) + :export + (pprint-glil + make- ? + -1 -2 -3 -4 -5 + make- ? -1 -2 + + make- ? + make- ? -1 + + make- ? -1 -2 + make- ? -1 -2 + make- ? + -1 -2 -3 + make- ? + -1 -2 -3 + + make- ? -1 + make- ? -1 -2 + make- ? -1 -2 + make- ? -1 + )) + +;; Meta operations +(define-structure ( nargs nrest nlocs nexts body)) +(define-structure ( type syms)) + +;; Constants +(define-structure ()) +(define-structure ( obj)) + +;; Variables +(define-structure ( op index)) +(define-structure ( op index)) +(define-structure ( op depth index)) +(define-structure ( op module name)) + +;; Controls +(define-structure ( label)) +(define-structure ( inst label)) +(define-structure ( inst n)) +(define-structure ( inst)) + + +;;; +;;; Parser +;;; + +;; FIXME: This is not working now + +;;; (define (parse-glil x) +;;; (match x +;;; (('@asm args . body) +;;; (let* ((env (make-new-env e)) +;;; (args (parse-args args env))) +;;; (make-asm env args (map-parse body env)))) +;;; (else +;;; (error "Invalid assembly code:" x)))) +;;; +;;; (define (parse-args x e) +;;; (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t)) +;;; ((list? x) (make-args (map make-local-var x) #f)) +;;; (else (let loop ((l x) (v '())) +;;; (if (pair? l) +;;; (loop (cdr l) (cons (car l) v)) +;;; (make-args (map make-local-var +;;; (reverse! (cons l v))) +;;; #t))))))) +;;; (for-each (lambda (v) (env-add! e v)) (args-vars args)) +;;; args)) +;;; +;;; (define (map-parse x e) +;;; (map (lambda (x) (parse x e)) x)) +;;; +;;; (define (parse x e) +;;; (match x +;;; ;; (@asm ARGS BODY...) +;;; (('@asm args . body) +;;; (parse-asm x e)) +;;; ;; (@bind VARS BODY...) +;;; ;; (@block VARS BODY...) +;;; (((or '@bind '@block) vars . body) +;;; (let* ((offset (env-nvars e)) +;;; (vars (args-vars (parse-args vars e))) +;;; (block (make-block (car x) offset vars (map-parse body e)))) +;;; (for-each (lambda (v) (env-remove! e)) vars) +;;; block)) +;;; ;; (void) +;;; (('void) +;;; (make-void)) +;;; ;; (const OBJ) +;;; (('const obj) +;;; (make-const obj)) +;;; ;; (ref NAME) +;;; ;; (set NAME) +;;; (((or 'ref 'set) name) +;;; (make-access (car x) (env-ref e name))) +;;; ;; (label LABEL) +;;; (('label label) +;;; (make-label label)) +;;; ;; (br-if LABEL) +;;; ;; (jump LABEL) +;;; (((or 'br-if 'jump) label) +;;; (make-instl (car x) label)) +;;; ;; (call NARGS) +;;; ;; (tail-call NARGS) +;;; (((or 'call 'tail-call) n) +;;; (make-instn (car x) n)) +;;; ;; (INST) +;;; ((inst) +;;; (if (instruction? inst) +;;; (make-inst inst) +;;; (error "Unknown instruction:" inst))))) + + +;;; +;;; Unparser +;;; + +(define (unparse glil) + (match glil + ;; meta + (($ nargs nrest nlocs nexts body) + `(@asm (,nargs ,nrest ,nlocs ,nexts) ,@(map unparse body))) + (($ type syms) `(,type ,@syms)) + ;; constants + (($ ) `(void)) + (($ obj) `(const ,obj)) + ;; variables + (($ op index) + `(,(symbol-append 'argument- op) ,index)) + (($ op index) + `(,(symbol-append 'local- op) ,index)) + (($ op depth index) + `(,(symbol-append 'external- op) ,depth ,index)) + (($ op module name) + `(,(symbol-append 'module- op) ,module ,name)) + ;; controls + (($ label) `(label ,label)) + (($ inst label) `(,inst ,label)) + (($ inst n) `(,inst ,n)) + (($ inst) `(,inst)))) + + +;;; +;;; Printer +;;; + +(define (pprint-glil glil) + (let print ((code (unparse glil)) (column 0)) + (display (make-string column #\space)) + (case (car code) + ((@asm) + (format #t "(@asm ~A\n" (cadr code)) + (let ((col (+ column 2))) + (let loop ((l (cddr code))) + (print (car l) col) + (if (null? (cdr l)) + (display ")") + (begin (newline) (loop (cdr l))))))) + (else (write code)))) + (newline)) diff --git a/module/system/il/macros.scm b/module/system/il/macros.scm new file mode 100644 index 000000000..2897f3e8e --- /dev/null +++ b/module/system/il/macros.scm @@ -0,0 +1,435 @@ +;;; GHIL macros + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (system il macros) + :use-module (ice-9 match)) + +(define (make-label) (gensym ":L")) +(define (make-sym) (gensym "_")) + +;;; +;;; Module macros +;;; + +(define (@import identifier) + `((@ System::Base::module::do-import) (@quote ,identifier))) + + +;;; +;;; Syntax +;;; + +;; (@and X Y...) => +;; +;; (@if X (@and Y...) #f) +(define @and + (match-lambda* + (() #t) + ((x) x) + ((x . rest) `(@if ,x (@and ,@rest) #f)))) + +;; (@or X Y...) => +;; +;; (@let ((@_ X)) (@if @_ @_ (@or Y...))) +(define @or + (match-lambda* + (() #f) + ((x) x) + ((x . rest) + (let ((sym (make-sym))) + `(@let ((,sym ,x)) (@if ,sym ,sym (@or ,@rest))))))) + +;; (@while TEST BODY...) => +;; +;; (@goto L1) +;; L0: BODY... +;; L1: (@if TEST (@goto L0) (@void)) +;;; non-R5RS +(define (@while test . body) + (let ((L0 (make-label)) (L1 (make-label))) + `(@begin + (@goto ,L1) + (@label ,L0) ,@body + (@label ,L1) (@if ,test (@goto ,L0) (@void))))) + +;; (@cond (TEST BODY...) ...) => +;; +;; (@if TEST +;; (@begin BODY...) +;; (@cond ...)) +(define (@cond . clauses) + (cond ((null? clauses) (error "missing clauses")) + ((pair? (car clauses)) + (let ((c (car clauses)) (l (cdr clauses))) + (let ((rest (if (null? l) '(@void) `(@cond ,@l)))) + (cond ((eq? (car c) '@else) `(@begin (@void) ,@(cdr c))) + ((null? (cdr c)) `(@or ,(car c) ,rest)) + (else `(@if ,(car c) (@begin ,@(cdr c)) ,rest)))))) + (else (error "bad clause:" (car clauses))))) + +(define (@let* binds . body) + (if (null? binds) + `(@begin ,@body) + `(@let (,(car binds)) (@let* ,(cdr binds) ,@body)))) + + +;;; +;;; R5RS Procedures +;;; + +;; 6. Standard procedures + +;;; 6.1 Equivalence predicates + +(define (@eq? x y) `(@@ eq? ,x ,y)) +(define (@eqv? x y) `(@@ eqv? ,x ,y)) +(define (@equal? x y) `(@@ equal? ,x ,y)) + +;;; 6.2 Numbers + +(define (@number? x) `(@@ number? ,x)) +(define (@complex? x) `(@@ complex? ,x)) +(define (@real? x) `(@@ real? ,x)) +(define (@rational? x) `(@@ rational? ,x)) +(define (@integer? x) `(@@ integer? ,x)) + +(define (@exact? x) `(@@ exact? ,x)) +(define (@inexact? x) `(@@ inexact? ,x)) + +(define (@= x y) `(@@ ee? ,x ,y)) +(define (@< x y) `(@@ lt? ,x ,y)) +(define (@> x y) `(@@ gt? ,x ,y)) +(define (@<= x y) `(@@ le? ,x ,y)) +(define (@>= x y) `(@@ ge? ,x ,y)) + +(define (@zero? x) `(@= ,x 0)) +(define (@positive? x) `(@> ,x 0)) +(define (@negative? x) `(@< ,x 0)) +(define (@odd? x) `(@= (@modulo ,x 2) 1)) +(define (@even? x) `(@= (@modulo ,x 2) 0)) + +(define (@max . args) `(@@ max ,@args)) +(define (@min . args) `(@@ min ,@args)) + +(define @+ + (match-lambda* + (() 0) + ((x) x) + ((x y) `(@@ add ,x ,y)) + ((x y . rest) `(@@ add ,x (@+ ,y ,@rest))))) + +(define @* + (match-lambda* + (() 1) + ((x) x) + ((x y) `(@@ mul ,x ,y)) + ((x y . rest) `(@@ mul ,x (@* ,y ,@rest))))) + +(define @- + (match-lambda* + ((x) `(@@ neg ,x)) + ((x y) `(@@ sub ,x ,y)) + ((x y . rest) `(@@ sub ,x (@+ ,y ,@rest))))) + +(define @/ + (match-lambda* + ((x) `(@@ rec ,x)) + ((x y) `(@@ div ,x ,y)) + ((x y . rest) `(@@ div ,x (@* ,y ,@rest))))) + +;;; abs +;;; +;;; quotient +(define (@remainder x y) `(@@ remainder ,x ,y)) +;;; modulo +;;; +;;; gcd +;;; lcm +;;; +;;; numerator +;;; denominator +;;; +;;; floor +;;; ceiling +;;; truncate +;;; round +;;; +;;; rationalize +;;; +;;; exp +;;; log +;;; sin +;;; cos +;;; tan +;;; asin +;;; acos +;;; atan +;;; +;;; sqrt +;;; expt +;;; +;;; make-rectangular +;;; make-polar +;;; real-part +;;; imag-part +;;; magnitude +;;; angle +;;; +;;; exact->inexact +;;; inexact->exact +;;; +;;; number->string +;;; string->number + +;;; 6.3 Other data types + +;;;; 6.3.1 Booleans + +(define (@not x) `(@@ not ,x)) +(define (@boolean? x) `(@@ boolean? ,x)) + +;;;; 6.3.2 Pairs and lists + +(define (@pair? x) `(@@ pair? ,x)) +(define (@cons x y) `(@@ cons ,x ,y)) + +(define (@car x) `(@@ car ,x)) +(define (@cdr x) `(@@ cdr ,x)) +(define (@set-car! x) `(@@ set-car! ,x)) +(define (@set-cdr! x) `(@@ set-cdr! ,x)) + +(define (@caar x) `(@@ car (@@ car ,x))) +(define (@cadr x) `(@@ car (@@ cdr ,x))) +(define (@cdar x) `(@@ cdr (@@ car ,x))) +(define (@cddr x) `(@@ cdr (@@ cdr ,x))) +(define (@caaar x) `(@@ car (@@ car (@@ car ,x)))) +(define (@caadr x) `(@@ car (@@ car (@@ cdr ,x)))) +(define (@cadar x) `(@@ car (@@ cdr (@@ car ,x)))) +(define (@caddr x) `(@@ car (@@ cdr (@@ cdr ,x)))) +(define (@cdaar x) `(@@ cdr (@@ car (@@ car ,x)))) +(define (@cdadr x) `(@@ cdr (@@ car (@@ cdr ,x)))) +(define (@cddar x) `(@@ cdr (@@ cdr (@@ car ,x)))) +(define (@cdddr x) `(@@ cdr (@@ cdr (@@ cdr ,x)))) +(define (@caaaar x) `(@@ car (@@ car (@@ car (@@ car ,x))))) +(define (@caaadr x) `(@@ car (@@ car (@@ car (@@ cdr ,x))))) +(define (@caadar x) `(@@ car (@@ car (@@ cdr (@@ car ,x))))) +(define (@caaddr x) `(@@ car (@@ car (@@ cdr (@@ cdr ,x))))) +(define (@cadaar x) `(@@ car (@@ cdr (@@ car (@@ car ,x))))) +(define (@cadadr x) `(@@ car (@@ cdr (@@ car (@@ cdr ,x))))) +(define (@caddar x) `(@@ car (@@ cdr (@@ cdr (@@ car ,x))))) +(define (@cadddr x) `(@@ car (@@ cdr (@@ cdr (@@ cdr ,x))))) +(define (@cdaaar x) `(@@ cdr (@@ car (@@ car (@@ car ,x))))) +(define (@cdaadr x) `(@@ cdr (@@ car (@@ car (@@ cdr ,x))))) +(define (@cdadar x) `(@@ cdr (@@ car (@@ cdr (@@ car ,x))))) +(define (@cdaddr x) `(@@ cdr (@@ car (@@ cdr (@@ cdr ,x))))) +(define (@cddaar x) `(@@ cdr (@@ cdr (@@ car (@@ car ,x))))) +(define (@cddadr x) `(@@ cdr (@@ cdr (@@ car (@@ cdr ,x))))) +(define (@cdddar x) `(@@ cdr (@@ cdr (@@ cdr (@@ car ,x))))) +(define (@cddddr x) `(@@ cdr (@@ cdr (@@ cdr (@@ cdr ,x))))) + +(define (@null? x) `(@@ null? ,x)) +(define (@list? x) `(@@ list? ,x)) +(define (@list . args) `(@@ list ,@args)) + +;;; length +;;; append +;;; reverse +;;; list-tail +;;; list-ref +;;; +;;; memq +;;; memv +;;; member +;;; +;;; assq +;;; assv +;;; assoc + +;;;; 6.3.3 Symbols + +;;; symbol? +;;; symbol->string +;;; string->symbol + +;;;; 6.3.4 Characters + +;;; char? +;;; char=? +;;; char? +;;; char<=? +;;; char>=? +;;; char-ci=? +;;; char-ci? +;;; char-ci<=? +;;; char-ci>=? +;;; char-alphabetic? +;;; char-numeric? +;;; char-whitespace? +;;; char-upper-case? +;;; char-lower-case? +;;; char->integer +;;; integer->char +;;; char-upcase +;;; char-downcase + +;;;; 6.3.5 Strings + +;;; string? +;;; make-string +;;; string +;;; string-length +;;; string-ref +;;; string-set! +;;; +;;; string=? +;;; string-ci=? +;;; string? +;;; string<=? +;;; string>=? +;;; string-ci? +;;; string-ci<=? +;;; string-ci>=? +;;; +;;; substring +;;; string-append +;;; string->list +;;; list->string +;;; string-copy +;;; string-fill! + +;;;; 6.3.6 Vectors + +;;; vector? +;;; make-vector +;;; vector +;;; vector-length +;;; vector-ref +;;; vector-set! +;;; vector->list +;;; list->vector +;;; vector-fill! + +;;;; 6.4 Control features + +(define (@procedure? x) `(@@ procedure? x)) + +;; (define (@apply proc . args) ...) + +(define (@map f ls . more) + (if (null? more) + `(@let ((f ,f)) + (@let map1 ((ls ,ls)) + (@if (@null? ls) + '() + (@cons (f (car ls)) (map1 (cdr ls)))))) + `(@let ((f ,f)) + (@let map-more ((ls ,ls) (more ,more)) + (@if (@null? ls) + '() + (@cons (@apply f (car ls) (map car more)) + (map-more (cdr ls) (map cdr more)))))))) + +(define @for-each + (match-lambda* + ((f l) + (do ((ls ls (cdr ls)) (more more (map cdr more))) + ((null? ls)) + (apply f (car ls) (map car more)))) + ((f . args) + `(@apply (@~ system:il:base:for-each) args)))) + +(define (@force promise) `(@@ force promise)) + +(define (@call-with-current-continuation proc) `(@@ call/cc proc)) + +(define @call/cc @call-with-current-continuation) + +;;; values +;;; call-with-values +;;; dynamic-wind + +;;; 6.5 Eval + +;;; eval +;;; scheme-report-environment +;;; null-environment +;;; interaction-environment + +;;; 6.6 Input and output + +;;;; 6.6.1 Ports + +;;; call-with-input-file +;;; call-with-output-file +;;; +;;; input-port? +;;; output-port? +;;; current-input-port +;;; current-output-port +;;; +;;; with-input-from-file +;;; with-output-to-file +;;; +;;; open-input-file +;;; open-output-file +;;; close-input-port +;;; close-output-port + +;;;; 6.6.2 Input + +;;; read +;;; read-char +;;; peek-char +;;; eof-object? +;;; char-ready? + +;;;; 6.6.3 Output + +;;; write +;;; display +;;; newline +;;; write-char + +;;;; 6.6.4 System interface + +;;; load +;;; transcript-on +;;; transcript-off + + +;;; +;;; Non-R5RS Procedures +;;; + +(define @cons* + (match-lambda* + ((x) x) + ((x y) `(@cons ,x ,y)) + ((x y . rest) `(@cons ,x (@cons* ,y ,@rest))))) + +(define (@error . args) `(@@ display ,@args)) + +(define (@current-module) + `((@ System::Base::module::current-module))) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm new file mode 100644 index 000000000..c18016fc4 --- /dev/null +++ b/module/system/repl/command.scm @@ -0,0 +1,506 @@ +;;; command.scm --- 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-module (oop goops) + :use-syntax (system base syntax) + :use-module (system base module) + :use-module (system base language) + :use-module (system repl common) + :use-module (system il glil) + :use-module (system vm core) + :use-module (system vm trace) + :use-module (system vm disasm) + :use-module (system vm profile) + :use-module (ice-9 format) + :use-module (ice-9 session) + :use-module (ice-9 debugger) + :export (meta-command)) + +(define (puts x) (display x) (newline)) + +(define (user-error msg . args) + (throw 'user-error #f msg args #f)) + + +;;; +;;; Meta command +;;; + +(define *command-table* + '((help (help h) (apropos a) (describe d) (option o) (quit q)) + (module (module m) (use u) (import i) (load l) (binding b) (lsmod lm)) + (package (package p) (lspkg lp) (autopackage) (globals g)) + (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 (statistics stat) (gc)))) + +(define (group-name g) (car g)) +(define (group-commands g) (cdr g)) + +(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 opts)))) + (user-error "Unknown meta command: ~A" key)))))))) + + +;;; +;;; Help commands +;;; + +(define (help repl . args) + "help [GROUP] +Show help messages. +The optional argument can be either one of command groups or +command names. Without argument, a list of help commands and +all command groups are displayed, as you have already seen :)" + (match 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 "Enter `,COMMAND -h' to display documentation of each command.") + (newline)) + (('all) + (for-each display-group *command-table*)) + ((? 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 [options] REGEXP +Find bindings/modules/packages." + (guile-apropos (object->string regexp display))) + +(define (describe repl obj) + "describe OBJ +Show description/documentation." + (display "Not implemented yet\n")) + +(define (option repl . args) + "option [KEY [VALUE]] +List/show/set options." + (display "Not implemented yet\n")) + +(define (quit repl) + "quit +Quit this session." + (throw 'quit)) + + +;;; +;;; Module commands +;;; + +(define (module repl . args) + "module [MODULE] +Change modules / Show current module." + (match args + (() (puts (binding repl.module))))) + +(define (use repl . args) + "use [MODULE ...] +Use modules." + (define (use name) + (let ((mod (resolve-interface name))) + (if mod + (module-use! repl.module mod) + (user-error "No such module: ~A" name)))) + (if (null? args) + (for-each puts (map module-name + (cons repl.module (module-uses repl.module)))) + (for-each (lambda (name) + (cond + ((pair? name) (use name)) + ((symbol? name) + (cond ((find-one-module (symbol->string name)) => use))) + (else (user-error "Invalid module name: ~A" name)))) + args))) + +(define (import repl . args) + "import [MODULE ...] +Import modules / List those imported." + (define (use name) + (let ((mod (resolve-interface name))) + (if mod + (module-use! repl.module mod) + (user-error "No such module: ~A" name)))) + (if (null? args) + (for-each puts (map module-name + (cons repl.module (module-uses repl.module)))) + (for-each (lambda (name) + (cond + ((pair? name) (use name)) + ((symbol? name) + (and-let* ((m (find-one-module (symbol->string name)))) + (puts m) (use m))) + (else (user-error "Invalid module name: ~A" name)))) + args))) + +(define (load repl file . opts) + "load [options] FILE +Load a file in the current module." + (apply repl-load-file repl (->string file) opts)) + +(define (binding repl . opts) + "binding [-a] +List current bindings." + (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.module)) + +(define (lsmod repl . args) + "lsmod +." + (define (use name) + (set! repl.module (resolve-module name)) + (module-use! repl.module repl.value-history)) + (if (null? args) + (use '(guile-user)) + (let ((name (car args))) + (cond + ((pair? name) (use name)) + ((symbol? name) + (and-let* ((m (find-one-module (symbol->string name)))) + (puts m) (use m))) + (else (user-error "Invalid module name: ~A" name)))))) + + +;;; +;;; Package commands +;;; + +(define (package repl) + "package [PACKAGE] +List available packages/modules." + (for-each puts (find-module ""))) + +(define (lspkg repl) + "lspkg +List available packages/modules." + (for-each puts (find-module ""))) + +(define (autopackage repl) + "autopackage +List available packages/modules." + (for-each puts (find-module ""))) + +(define (globals repl) + "globals +List all global variables." + (global-fold (lambda (s v d) (format #t "~A\t~S\n" s v)) #f)) + + +;;; +;;; Language commands +;;; + +(define (language repl name) + "language LANGUAGE +Change languages." + (set! repl.language (lookup-language name)) + (repl-welcome repl)) + + +;;; +;;; Compile commands +;;; + +(define (compile repl form . opts) + "compile [options] FORM +Generate compiled code. + + -e Stop after expanding syntax/macro + -t Stop after translating into GHIL + -c Stop after generating GLIL + -l Stop before linking + -o Compile into bytecode + + -O Enable optimization + -D Add debug information" + (let ((x (apply repl-compile repl form opts))) + (cond ((null? opts) + (disassemble-program x)) + ((memq :l opts) + (disassemble-bytecode x)) + ((memq :c opts) + (pprint-glil x)) + (else + (puts x))))) + +(define (compile-file repl file . opts) + "compile-file [options] FILE +Compile a file." + (apply repl-compile-file repl (->string file) opts)) + +(define (disassemble repl prog) + "disassemble PROGRAM +Disassemble a program." + (disassemble-program (repl.vm (repl-compile repl prog)))) + +(define (disassemble-file repl file) + "disassemble-file FILE +Disassemble a file." + (disassemble-bytecode (load-file-in (->string file) + repl.module + repl.language))) + +(define (->string x) + (object->string x display)) + + +;;; +;;; Profile commands +;;; + +(define (profile repl form . opts) + "profile FORM +Profile execution." + (apply vm-profile repl.vm (repl-compile repl form) opts)) + + +;;; +;;; Debug commands +;;; + +(define guile-backtrace backtrace) +(define (backtrace repl) + "backtrace +Show backtrace (if any)." + (guile-backtrace)) + +(define (debugger repl) + "debugger +Start debugger." + (debug)) + +(define (trace repl form . opts) + "trace [-a] FORM +Trace execution." + (apply vm-trace repl.vm (repl-compile repl form) opts)) + +(define (step repl) + "step FORM +Step execution." + (display "Not implemented yet\n")) + + +;;; +;;; System commands +;;; + +(define (time repl form) + "time FORM +Time execution." + (let* ((vms-start (vm-stats repl.vm)) + (gc-start (gc-run-time)) + (tms-start (times)) + (result (repl-eval repl form)) + (tms-end (times)) + (gc-end (gc-run-time)) + (vms-end (vm-stats repl.vm))) + (define (get proc start end) + (/ (- (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 id gc-start gc-end)) + result)) + +;;; +;;; Statistics +;;; + +(define guile-gc gc) +(define (gc repl) + "gc +Garbage collection." + (guile-gc)) + +(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" (/ 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)))) + (display-stat title #f + (mips (- this-time last-time) (- this-clock last-clock)) + (mips this-time this-clock) "mips")) + +(define (statistics repl) + "statistics +Display statistics." + (let ((this-tms (times)) + (this-vms (vm-stats repl.vm)) + (this-gcs (gc-stats)) + (last-tms repl.tm-stats) + (last-vms repl.vm-stats) + (last-gcs repl.gc-stats)) + ;; 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-sweep (assq-ref this-gcs 'gc-sweep-time-taken)) + (last-sweep (assq-ref last-gcs 'gc-sweep-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 "sweep" this-sweep last-sweep) + (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 this-tms) + (set! repl.vm-stats this-vms) + (set! repl.gc-stats this-gcs))) + +;;; repl.scm ends here diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm new file mode 100644 index 000000000..4e0753593 --- /dev/null +++ b/module/system/repl/common.scm @@ -0,0 +1,93 @@ +;;; common.scm --- 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-module (oop goops) + :use-syntax (system base syntax) + :use-module (system base module) + :use-module (system base language) + :use-module (system vm core) + :export (make-repl repl-welcome repl-prompt repl-read repl-compile + repl-eval repl-print repl-compile-file repl-load-file)) + + +;;; +;;; Repl +;;; + +(define-vm-class () + vm language module value-count value-history tm-stats vm-stats gc-stats) + +(define (make-repl lang) + (let ((vm (make-vm))) + (make + :vm vm + :language (lookup-language lang) + :module (global-ref 'user) + :value-count 0 +; :value-history (make-vmodule) + :tm-stats (times) + :vm-stats (vm-stats vm) + :gc-stats (gc-stats)))) + +(define (repl-welcome repl) + (format #t "~A interpreter ~A on Guile ~A\n" + repl.language.title repl.language.version (version)) + (display "Copyright (C) 2001 Free Software Foundation, Inc.\n\n") + (display "Enter `,help' for help.\n")) + +(define (repl-prompt repl) + (format #t "~A@~A> " repl.language.name (env-identifier repl.module)) + (force-output)) + +(define (repl-read repl . args) + (apply read-in repl.language args)) + +(define (repl-compile repl form . opts) + (let ((bytes (apply compile-in form repl.module repl.language opts))) + (if (or (memq :c opts) (memq :l opts)) + bytes + (vm-load repl.vm bytes)))) + +(define (repl-eval repl form) + (let ((evaler repl.language.evaler)) + (if evaler + (evaler form repl.module) + (repl.vm (repl-compile repl form))))) + +(define (repl-print repl val) + (if (not (eq? val *unspecified*)) + (let* ((num (1+ repl.value-count)) + (sym (string->symbol (format #f "$~A" num)))) +; (vmodule-define repl.value-history sym val) + (format #t "~A = " sym) + (print-in val repl.language) + (newline) + (set! repl.value-count num)))) + +(define (repl-compile-file repl form . opts) + (apply compile-file-in form repl.module repl.language opts)) + +(define (repl-load-file repl file . opts) + (let ((bytes (apply load-file-in file repl.module repl.language opts))) + (repl.vm (vm-load repl.vm bytes)))) + +;;; common.scm ends here diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm new file mode 100644 index 000000000..17e46621f --- /dev/null +++ b/module/system/repl/describe.scm @@ -0,0 +1,364 @@ +;;; describe.scm --- 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)) + +(define *describe-format* #t) + +(define-public (describe symbol) + (assert symbol? symbol) + (format #t "`~s' is " symbol) + (if (not (defined? symbol)) + (display "not defined in the current module.\n") + (describe-object (eval symbol)))) + + +;;; +;;; Display functions +;;; + +(define (safe-class-name class) + (if (slot-bound? class 'name) + (class-name class) + class)) + +(define-method (display-class class . args) + (let* ((name (safe-class-name class)) + (desc (if (pair? args) (car args) name))) + (if (eq? *describe-format* 'tag) + (format #t "@class{~a}{~a}" name desc) + (format #t "~a" desc)))) + +(define-public (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-public (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-public (display-file location) + (display "Defined in ") + (if (eq? *describe-format* 'tag) + (format #t "@location{~a}.\n" location) + (format #t "`~a'.\n" location))) + +(define-public (format-documentation doc) + (with-current-buffer (make-buffer #:text doc) + (lambda () + (let ((regexp (make-regexp "@([a-z]*)(\\{([^\}]*)\\})?"))) + (do-while (match (re-search-forward regexp)) + (let ((key (string->symbol (match:substring match 1))) + (value (match:substring match 3))) + (case key + ((deffnx) + (delete-region! (match:start match) + (begin (forward-line) (point)))) + ((var) + (replace-match! match 0 (string-upcase value))) + ((code) + (replace-match! match 0 (string-append "`" value "'"))))))) + (display (string (current-buffer))) + (newline)))) + + +;;; +;;; Top +;;; + +(define description-table + (list + (cons "a boolean") + (cons "an empty list") + (cons "an integer") + (cons "a real number") + (cons "a complex number") + (cons "a character") + (cons "a symbol") + (cons "a keyword") + (cons "a promise") + (cons "a hook") + (cons "a fluid") + (cons "a stack") + (cons "a variable") + (cons "a regexp object") + (cons "a module object") + (cons "an unknown object"))) + +(define-generic describe-object) +(export describe-object) + +(define-method (describe-object (obj )) + (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 )) + (write obj)) + +(define-method (display-summary (obj )) + (display "Value: ") + (display-object obj) + (newline)) + +(define-method (display-type (obj )) + (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 )) + (if (not (unspecified? obj)) + (begin (display-object obj) (newline)))) + +(define-method (display-location (obj )) + *unspecified*) + +(define-method (display-description (obj )) + (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 )) + (display "Not documented.\n")) + + +;;; +;;; Pairs +;;; + +(define-method (display-type (obj )) + (cond + ((list? obj) (display-class "a list")) + ((pair? (cdr obj)) (display "an improper list")) + (else (display-class "a pair"))) + (display ".\n")) + + +;;; +;;; Strings +;;; + +(define-method (display-type (obj )) + (if (read-only-string? 'obj) + (display "a read-only string") + (display-class "a string")) + (display ".\n")) + + +;;; +;;; Procedures +;;; + +(define-method (display-object (obj )) + (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 )) + (display "Procedure: ") + (display-object obj) + (newline) + (display " ") + (display-description obj)) + +(define-method (display-type (obj )) + (cond + ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk")) + ((closure? obj) (display-class "a procedure")) + ((procedure-with-setter? obj) + (display-class "a procedure with setter")) + ((not (struct? obj)) (display "a primitive procedure")) + (else (display-class "a procedure"))) + (display ".\n")) + +(define-method (display-location (obj )) + (and-let* ((entry (lookup-procedure obj))) + (display-file (entry-file entry)))) + +(define-method (display-documentation (obj )) + (cond ((cond ((closure? obj) (procedure-documentation obj)) + ((lookup-procedure obj) => entry-text) + (else #f)) + => format-documentation) + (else (next-method)))) + + +;;; +;;; Classes +;;; + +(define-method (describe-object (obj )) + (display-type obj) + (display-location obj) + (newline) + (display-documentation obj) + (newline) + (display-value obj)) + +(define-method (display-summary (obj )) + (display "Class: ") + (display-class obj) + (newline) + (display " ") + (display-description obj)) + +(define-method (display-type (obj )) + (display-class "a class") + (if (not (eq? (class-of obj) )) + (begin (display " of ") (display-class (class-of obj)))) + (display ".\n")) + +(define-method (display-value (obj )) + (display-list "Class precedence list" (class-precedence-list obj)) + (newline) + (display-list "Direct superclasses" (class-direct-supers obj)) + (newline) + (display-list "Direct subclasses" (class-direct-subclasses obj)) + (newline) + (display-slot-list "Direct slots" #f (class-direct-slots obj)) + (newline) + (display-list "Direct methods" (class-direct-methods obj))) + + +;;; +;;; Instances +;;; + +(define-method display-type ((obj )) + (display-class "an instance") + (display " of class ") + (display-class (class-of obj)) + (display ".\n")) + +(define-method display-value ((obj )) + (display-slot-list #f obj (class-slots (class-of obj)))) + + +;;; +;;; Generic functions +;;; + +(define-method display-type ((obj )) + (display-class "a generic function") + (display " of class ") + (display-class (class-of obj)) + (display ".\n")) + +(define-method display-value ((obj )) + (display-list #f (generic-function-methods obj))) + + +;;; +;;; Methods +;;; + +(define-method (display-object (obj )) + (display "(") + (let ((gf (method-generic-function obj))) + (display (if gf (generic-function-name gf) "#"))) + (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 )) + (display "Method: ") + (display-object obj) + (newline) + (display " ") + (display-description obj)) + +(define-method (display-type (obj )) + (display-class "a method") + (display " of class ") + (display-class (class-of obj)) + (display ".\n")) + +(define-method (display-documentation (obj )) + (let ((doc (procedure-documentation (method-procedure obj)))) + (if doc (format-documentation doc) (next-method)))) + +;;; describe.scm ends here diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm new file mode 100644 index 000000000..8fbe50e4d --- /dev/null +++ b/module/system/repl/repl.scm @@ -0,0 +1,74 @@ +;;; 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 module) + :use-module (system repl common) + :use-module (system repl command) + :use-module (system vm frame) + :use-module (ice-9 rdelim) + :export (start-repl)) + +(define (start-repl lang) + (let ((repl (make-repl lang))) + (set-current-vmodule! repl.module) + (set-current-evaluator! repl.vm) + (repl-welcome repl) + (let prompt-loop () + (repl-prompt repl) + (call-with-error-handlers + (lambda () + (if (eq? (next-char #t) #\,) + ;; meta command + (begin (read-char) + (meta-command repl (read-line))) + ;; evaluation + (let rep-loop () + (repl-print repl (repl-eval repl (repl-read repl))) + (if (next-char #f) (rep-loop)))))) + (prompt-loop)))) + +(define (next-char wait) + (if (or wait (char-ready?)) + (let ((ch (peek-char))) + (cond ((eof-object? ch) (throw 'quit)) + ((char-whitespace? ch) (read-char) (next-char wait)) + (else ch))) + #f)) + +;;; +;;; Error handler +;;; + +(define (call-with-error-handlers thunk) + (catch 'vm-error + (lambda () (catch 'user-error thunk error-handler)) + error-handler)) + +(define (error-handler key . args) + (case key + ((vm-error) + (write (frame->call (cadddr args))) + (newline))) + (display "ERROR: ") + (apply format #t (cadr args) (caddr args)) + (newline)) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm new file mode 100644 index 000000000..dfddf5c28 --- /dev/null +++ b/module/system/vm/assemble.scm @@ -0,0 +1,327 @@ +;;; Guile VM assembler + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (system vm assemble) + :use-syntax (system base syntax) + :use-module (system base module) + :use-module (system il glil) + :use-module (system vm core) + :use-module (system vm conv) + :use-module (ice-9 match) + :use-module (ice-9 regex) + :use-module (ice-9 common-list) + :export (assemble)) + +(define (assemble glil env . opts) + (dump (codegen (preprocess glil #f) #t))) + + +;;; +;;; Types +;;; + +(define-structure ( venv glil body)) +(define-structure (venv parent nexts closure?)) +(define-structure (vmod id)) +(define-structure (vlink module name)) +(define-structure (bytespec nargs nrest nlocs bytes objs)) + + +;;; +;;; Stage 1: Preprocess +;;; + +(define (preprocess x e) + (match x + (($ nargs nrest nlocs nexts body) + (let* ((venv (make-venv e nexts #f)) + (body (map (lambda (x) (preprocess x venv)) body))) + (make- venv x body))) + (($ op depth index) + (do ((d depth (1- d)) + (e e (venv-parent e))) + ((= d 0)) + (set-venv-closure?! e #t)) + x) + (else x))) + + +;;; +;;; Stage 2: Bytecode generation +;;; + +(define (codegen glil toplevel) + (match glil + (($ venv ($ nargs nrest nlocs nexts _) body) + (let ((stack '()) + (label-alist '()) + (object-alist '()) + (nvars (+ nargs nlocs -1))) + (define (current-address) (length stack)) + (define (push-code! code) + (set! stack (optimizing-push code stack))) + (define (object-index obj) + (cond ((assq-ref object-alist obj)) + (else (let ((index (length object-alist))) + (set! object-alist (acons obj index object-alist)) + index)))) + (define (label-ref key) + (assq-ref label-alist key)) + (define (label-set key pos) + (set! label-alist (assq-set! label-alist key pos))) + (define (generate-code x) + (match x + (($ env) + (push-code! `(object-ref ,(object-index (codegen x #f)))) + (if (venv-closure? env) (push-code! `(make-closure)))) + + (($ ) + (push-code! `(void))) + + (($ x) + (if toplevel + (for-each push-code! (object->dump-code x)) + (cond ((object->code x) => push-code!) + (else (push-code! `(object-ref ,(object-index x))))))) + + (($ op index) + (push-code! (list (symbol-append 'local- op) + (- nvars index)))) + + (($ op index) + (push-code! (list (symbol-append 'local- op) + (- nvars (+ nargs index))))) + + (($ op depth index) + (do ((e venv (venv-parent e)) + (d depth (1- d)) + (i 0 (+ i (venv-nexts e)))) + ((= d 0) + (push-code! (list (symbol-append 'external- op) + (+ index i)))))) + + (($ op module name) + (let ((mod (make-vmod module))) + (if toplevel + (begin + (push-code! `(load-module ,module)) + (push-code! `(load-symbol ,name)) + (push-code! `(link))) + (let ((vlink (make-vlink mod name))) + (push-code! `(object-ref ,(object-index vlink))))) + (push-code! (list (symbol-append 'variable- op))))) + + (($ label) + (label-set label (current-address))) + + (($ inst label) + (let ((setter (lambda (addr) (- (label-ref label) (1+ addr))))) + (push-code! (list inst setter)))) + + (($ inst n) + (push-code! (list inst n))) + + (($ inst) + (if (instruction? inst) + (push-code! (list inst)) + (error "Unknown instruction:" inst))))) + ;; + ;; main + (if (> nexts 0) (push-code! `(external ,nexts))) + (for-each generate-code body) + (let ((bytes (code->bytes + (map/index (lambda (v n) (if (procedure? v) (v n) v)) + (reverse! stack)))) + (objs (map car (reverse! object-alist)))) + (make-bytespec nargs nrest nlocs bytes objs)))))) + +(define (map/index f l) + (do ((n 0 (1+ n)) + (l l (cdr l)) + (r '() (cons (f (car l) n) r))) + ((null? l) (reverse! r)))) + +;; Optimization + +(define *optimize-table* + '((not (not . not-not) + (eq? . not-eq?) + (null? . not-null?) + (not-not . not) + (not-eq? . eq?) + (not-null? . null?)) + (br-if (not . br-if-not) + (eq? . br-if-eq) + (null? . br-if-null) + (not-not . br-if) + (not-eq? . br-if-not-eq) + (not-null? . br-if-not-null)) + (br-if-not (not . br-if) + (eq? . br-if-not-eq) + (null? . br-if-not-null) + (not-not . br-if-not) + (not-eq? . br-if-eq) + (not-null? . br-if-null)))) + +(define (optimizing-push code stack) + (let ((alist (assq-ref *optimize-table* (car code)))) + (cond ((and alist (pair? stack) (assq-ref alist (car stack))) => + (lambda (inst) (append! (reverse! (cons inst (cdr code))) + (cdr stack)))) + (else (append! (reverse! (code-finalize code)) stack))))) + + +;;; +;;; Stage3: Dumpcode generation +;;; + +(define (dump bytespec) + (let* ((table (build-object-table bytespec)) + (bytes (bytespec->bytecode bytespec table '(return)))) + (if (null? table) + bytes + (let ((spec (make-bytespec 0 0 (length table) bytes '()))) + (bytespec->bytecode spec '() '(tail-call 0)))))) + +(define (bytespec->bytecode bytespec object-table last-code) + (let ((stack '())) + (define (push-code! x) + (set! stack (cons x stack))) + (define (object-index x) + (cond ((object-find object-table x) => cdr) + (else #f))) + (define (dump-table-object! obj+index) + (let dump! ((x (car obj+index))) + (cond + ((vlink? x) + (push-code! `(local-ref ,(object-index (vlink-module x)))) + (push-code! `(load-symbol ,(vlink-name x))) + (push-code! `(link))) + ((vmod? x) + (push-code! `(load-module ,(vmod-id x)))) + (else + (for-each push-code! (object->dump-code x))))) + (push-code! `(local-set ,(cdr obj+index)))) + (define (dump-object! x) + (let dump! ((x x)) + (cond + ((bytespec? x) (dump-bytecode! x)) + ((object-index x) => (lambda (i) (push-code! `(local-ref ,i)))) + (else + (error "Cannot dump:" x))))) + (define (dump-bytecode! spec) + (let ((nargs (bytespec-nargs spec)) + (nrest (bytespec-nrest spec)) + (nlocs (bytespec-nlocs spec)) + (objs (bytespec-objs spec))) + (if (and (null? objs) (< nargs 4) (< nlocs 16)) + ;; zero-object encoding + (push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs))) + (begin + ;; dump parameters + (push-code! (object->code nargs)) + (push-code! (object->code nrest)) + (push-code! (object->code nlocs)) + ;; dump object table + (cond ((null? objs) (push-code! (object->code #f))) + (else + (push-code! `(mark)) + (for-each dump-object! objs) + (push-code! `(vector)))))) + ;; dump bytecode + (push-code! `(load-program ,(bytespec-bytes spec))))) + ;; + ;; main + (for-each dump-table-object! object-table) + (dump-bytecode! bytespec) + (push-code! last-code) + (code->bytes (apply append! (map code-finalize (reverse! stack)))))) + +;; object table + +(define (object-find table x) + ((if (or (vlink? x) (vmod? x)) assoc assq) x table)) + +(define (build-object-table bytespec) + (let ((table '()) (index 0)) + (define (insert! x) + (if (vlink? x) (begin (insert! (vlink-module x)))) + (if (not (object-find table x)) + (begin + (set! table (acons x index table)) + (set! index (1+ index))))) + (let loop ((spec bytespec)) + (for-each (lambda (x) + (if (bytespec? x) (loop x) (insert! x))) + (bytespec-objs spec))) + (reverse! table))) + +;; code generation + +(define (code-finalize code) + (match code + ((inst (? symbol? s)) + (let ((str (symbol->string s))) + `(,inst ,(string-length str) ,str))) + ((inst (? string? s)) + `(,inst ,(string-length s) ,s)) + (else (code-pack code)))) + +(define (integer->string n) (make-string 1 (integer->char n))) + +(define (length->string len) + (define C integer->char) + (list->string + (cond ((< len 254) (list (C len))) + ((< len 65536) + (list (C 254) (C (quotient len 256)) (C (modulo len 256)))) + ((< len most-positive-fixnum) + (list (C 255) + (C (quotient len (* 256 256 256))) + (C (modulo (quotient len (* 256 256)) 256)) + (C (modulo (quotient len 256) 256)) + (C (modulo len 256)))) + (else (error "Too long" len))))) + +(define (code->bytes code) + (let* ((code (list->vector code)) + (size (vector-length code))) + (let loop ((i 0)) + (if (>= i size) + (apply string-append (vector->list code)) + (let ((inst (vector-ref code i))) + (if (not (instruction? inst)) + (error "Unknown instruction:" inst)) + (vector-set! code i (integer->string (instruction->opcode inst))) + (let ((bytes (instruction-length inst))) + (cond ((< bytes 0) + (vector-set! code i + (integer->string (instruction->opcode inst))) + (vector-set! code (+ i 1) + (length->string (vector-ref code (1+ i)))) + (loop (+ i 3))) + ((= bytes 0) (loop (+ i 1))) + (else + (let ((end (+ i 1 bytes))) + (do ((j (+ i 1) (1+ j))) + ((= j end) (loop end)) + (vector-set! code j (integer->string + (vector-ref code j))))))))))))) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm new file mode 100644 index 000000000..31993d2ac --- /dev/null +++ b/module/system/vm/conv.scm @@ -0,0 +1,137 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (system vm conv) + :use-module (system vm core) + :use-module (ice-9 match) + :use-module (ice-9 regex) + :export (code-pack code-unpack object->code object->dump-code code->object)) + +(define (code-pack code) + (match code + ((inst (? integer? n)) + (cond ((< n 10) + (let ((abbrev (string->symbol (format #f "~A:~A" inst n)))) + (if (instruction? abbrev) (list abbrev) code))) + ((> n 255) + (let ((double (string->symbol (format #f "~A*2" inst)))) + (if (instruction? double) + (list double (quotient n 256) (modulo n 256)) + (apply error "Index out of range:" code)))) + (else code))) + (else code))) + +(define (code-unpack code) + (let ((inst (symbol->string (car code)))) + (cond + ((string-match "^([^:]*):([0-9]+)$" inst) => + (lambda (data) + (cons* (string->symbol (match:substring data 1)) + (string->number (match:substring data 2)) + (cdr code)))) + (else code)))) + +(define (object->code x) + (cond ((eq? x #t) `(make-true)) + ((eq? x #f) `(make-false)) + ((null? x) `(make-eol)) + ((integer? 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 (object->dump-code x) + (let ((stack '())) + (define (push-code! code) + (set! stack (cons code stack))) + (let dump! ((x x)) + (cond + ((object->code x) => push-code!) + ((string? x) + (push-code! `(load-string ,x))) + ((symbol? x) + (push-code! `(load-symbol ,(symbol->string x)))) + ((keyword? x) + (push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x))))) + ((list? x) + (push-code! `(mark)) + (for-each dump! x) + (push-code! `(list))) + ((pair? x) + (dump! (car x)) + (dump! (cdr x)) + (push-code! `(cons))) + ((vector? x) + (push-code! `(mark)) + (for-each dump! (vector->list x)) + (push-code! `(vector))) + (else + (error "Cannot dump:" x)))) + (reverse! stack))) + +(define (code->object code) + (match 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)) + (else #f))) + +(define-public (make-byte-decoder bytes) + (let ((addr 0) (size (string-length bytes))) + (define (pop) + (let ((byte (char->integer (string-ref bytes addr)))) + (set! addr (1+ addr)) + byte)) + (define (pop-length) + (let ((len (pop))) + (cond ((< len 254) len) + ((= len 254) (+ (* (pop) 256) (pop))) + (else (+ (* (pop) 256 256 256) (* (pop) 256 256) + (* (pop) 256) (pop)))))) + (lambda () + (if (< addr size) + (let* ((start addr) + (inst (opcode->instruction (pop))) + (n (instruction-length inst)) + (code (if (< n 0) + ;; variable length + (let* ((end (+ (pop-length) addr)) + (str (substring bytes addr end))) + (set! addr end) + (list inst str)) + ;; fixed length + (do ((n n (1- n)) + (l '() (cons (pop) l))) + ((= n 0) (cons* inst (reverse! l))))))) + (values start code)) + #f)))) diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm new file mode 100644 index 000000000..808cc9ec7 --- /dev/null +++ b/module/system/vm/core.scm @@ -0,0 +1,35 @@ +;;; 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 core)) + +(dynamic-call "scm_init_vm" (dynamic-link "libguilevm.so")) + +(export vms:cons vms:time vms:clock) + +(define (vms:cons stat) (vector-ref stat 0)) +(define (vms:time stat) (vector-ref stat 1)) +(define (vms:clock stat) (vector-ref stat 2)) + +(module-export! (current-module) + (delq! '%module-public-interface + (hash-fold (lambda (k v d) (cons k d)) '() + (module-obarray (current-module))))) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm new file mode 100644 index 000000000..7ec24ed12 --- /dev/null +++ b/module/system/vm/disasm.scm @@ -0,0 +1,118 @@ +;;; Guile VM Disassembler + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (system vm disasm) + :use-module (system vm core) + :use-module (system vm conv) + :use-module (ice-9 regex) + :use-module (ice-9 match) + :use-module (ice-9 format) + :use-module (ice-9 receive) + :use-module (ice-9 and-let-star) + :export (disassemble-program disassemble-bytecode)) + +(define (disassemble-program prog . opts) + (let* ((arity (program-arity prog)) + (nargs (car arity)) + (nrest (cadr arity)) + (nlocs (caddr arity)) + (bytes (program-bytecode prog)) + (objs (program-objects prog))) + ;; Disassemble this bytecode + (format #t "Disassembly of ~A:\n\n" prog) + (format #t "args = ~A rest = ~A locals = ~A\n\n" nargs nrest nlocs) + (format #t "Bytecode:\n\n") + (disassemble-bytecode bytes objs) + (if (> (vector-length objs) 0) + (disassemble-objects objs)) + ;; Disassemble other bytecode in it + (for-each + (lambda (x) + (if (program? x) + (begin (display "----------------------------------------\n") + (apply disassemble-program x opts)))) + (vector->list objs)))) + +(define (disassemble-bytecode bytes . opt) + (let ((decode (make-byte-decoder bytes)) + (rest '())) + (do ((addr+code (decode) (decode))) + ((not addr+code) (newline)) + (receive (addr code) addr+code + (match code + (('load-program x) + (let ((sym (gensym ""))) + (set! rest (acons sym x rest)) + (print-info addr (format #f "load-program #~A" sym) #f))) + (else + (let ((info (list->string code)) + (extra (original-value code (if (null? opt) #f (car opt))))) + (print-info addr info extra)))))) + (for-each (lambda (sym+bytes) + (format #t "Bytecode #~A:\n\n" (car sym+bytes)) + (disassemble-bytecode (cdr sym+bytes))) + (reverse! rest)))) + +(define (disassemble-objects objs) + (display "Objects:\n\n") + (let ((len (vector-length objs))) + (do ((n 0 (1+ n))) + ((= n len) (newline)) + (let ((info (object->string (vector-ref objs n)))) + (print-info n info #f))))) + +(define (disassemble-meta meta) + (display "Meta info:\n\n") + (for-each (lambda (data) + (print-info (car data) (list->string (cdr data)) #f)) + meta) + (newline)) + +(define (original-value code table) + (define (branch-code? code) + (string-match "^(br|jump)" (symbol->string (car code)))) + (let ((code (code-unpack code))) + (cond ((code->object code) => object->string) +;;; ((branch-code? code) +;;; (format #f "-> ~A" (+ addr (cadr code)))) + (else + (let ((inst (car code)) (args (cdr code))) + (case inst + ((make-false) "#f") +;;; ((object-ref) +;;; (object->string (vector-ref objs (car args)))) + ((local-ref local-set) + ;;'(ref x)) + #f) +;;; ((module-ref module-set) +;;; (let ((var (vector-ref objs (car args)))) +;;; (list (if (eq? inst 'module-ref) 'ref 'set) +;;; (if (pair? var) (car var) var)))) + (else #f))))))) + +(define (list->string list) + (let ((str (object->string list))) + (substring str 1 (1- (string-length str))))) + +(define (print-info addr info extra) + (if extra + (format #t "~4@A ~24A;; ~A\n" addr info extra) + (format #t "~4@A ~A\n" addr info))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm new file mode 100644 index 000000000..5c043f2b1 --- /dev/null +++ b/module/system/vm/frame.scm @@ -0,0 +1,32 @@ +;;; Guile VM frame 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 vm frame) + :use-module (system vm core) + :export (frame->call)) + +(define (frame->call frame) + (let ((prog (frame-program frame))) + (cons prog (reverse! (vector->list (frame-variables frame)))))) + +; (define-method (binding (prog )) +; (fold (lambda (s v d) (if (eq? v prog) s d)) +; #f (program-environment prog))) diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm new file mode 100644 index 000000000..c92e6c441 --- /dev/null +++ b/module/system/vm/profile.scm @@ -0,0 +1,66 @@ +;;; 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 core) + :use-module (ice-9 format) + :export (vm-profile)) + +(define (vm-profile vm prog . 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 () + (let ((val (vm prog))) + (display-result vm) + val)) + (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 (display-result vm . opts) + (do ((data (vm-option vm 'profile-data) (cdr data)) + (summary '() (let ((inst (caar data))) + (assq-set! summary inst + (1+ (or (assq-ref summary inst) 0)))))) + ((null? data) + (display "Count Instruction\n") + (display "----- -----------\n") + (for-each (lambda (entry) + (format #t "~5@A ~A\n" (cdr entry) (car entry))) + (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2)))))))) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm new file mode 100644 index 000000000..88933003d --- /dev/null +++ b/module/system/vm/trace.scm @@ -0,0 +1,75 @@ +;;; 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-module (oop goops) + :use-syntax (system base syntax) + :use-module (system base module) + :use-module (system vm core) + :use-module (system vm frame) + :use-module (ice-9 format) + :export (vm-trace)) + +(define (vm-trace vm prog . opts) + (let ((flag (vm-option vm 'debug))) + (dynamic-wind + (lambda () + (set-vm-option! vm 'debug #t) + (set-vm-option! vm 'first-apply #t) + (if (memq :a opts) + (add-hook! (vm-next-hook vm) trace-next)) + (add-hook! (vm-apply-hook vm) trace-apply) + (add-hook! (vm-return-hook vm) trace-return)) + (lambda () + (vm prog)) + (lambda () + (set-vm-option! vm 'debug flag) + (if (memq :a 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) + (let ((frame (vm-current-frame vm))) + (format #t "0x~X ~20S~S\t~S\n" + (vm:ip vm) + (vm-fetch-code vm) + (frame-variables frame) + (vm-fetch-stack vm)))) + +(define (trace-apply vm) + (if (vm-option vm 'first-apply) + (set-vm-option! vm 'first-apply #f) ;; skip the initial program + (let ((frame (vm-current-frame vm))) + (print-prefix (frame-dynamic-link frame)) + (write (frame->call frame)) + (newline)))) + +(define (trace-return vm) + (let ((frame (vm-current-frame vm))) + (print-prefix (frame-dynamic-link frame)) + (write (car (vm-fetch-stack vm))) + (newline))) + +(define (print-prefix frame) + (and-let* ((link (frame-dynamic-link frame))) + (display "| ") + (print-prefix link))) diff --git a/src/.cvsignore b/src/.cvsignore index 0ca232e65..9403d5368 100644 --- a/src/.cvsignore +++ b/src/.cvsignore @@ -1,8 +1,6 @@ -.cvsignore .libs .deps guile-vm -guile-compile stamp-h config.h config.h.in @@ -10,8 +8,6 @@ stamp-h.in Makefile Makefile.in *.x -*.inst -*.label -*.opcode +*.i *.lo *.la diff --git a/src/Makefile.am b/src/Makefile.am index 56b724975..621c450ab 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -3,39 +3,27 @@ guile_vm_SOURCES = guile-vm.c guile_vm_LDADD = libguilevm.la guile_vm_LDFLAGS = $(GUILE_LDFLAGS) -bin_SCRIPTS = guile-compile - lib_LTLIBRARIES = libguilevm.la -libguilevm_la_SOURCES = vm.c +libguilevm_la_SOURCES = envs.c instructions.c programs.c vm.c \ + envs.h instructions.h programs.h vm.h vm_engine.h vm_expand.h libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic -noinst_HEADERS = vm.h vm_engine.h vm_expand.h -EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c \ - test.scm guile-compile.in -BUILT_SOURCES = vm_system.i vm_scheme.i vm_number.i vm.x +EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c vm_loader.c +BUILT_SOURCES = vm_system.i vm_scheme.i vm_number.i vm_loader.i \ + envs.x instructions.x programs.x vm.x -CFLAGS = -g -O2 -Wall INCLUDES = $(GUILE_CFLAGS) -CLEANFILES = $(bin_SCRIPTS) DISTCLEANFILES = $(BUILT_SOURCES) MAINTAINERCLEANFILES = Makefile.in config.h.in stamp-h.in +ETAGS_ARGS = --regex='/SCM_\(SYMBOL\|VCELL\).*\"\([^\"]\)*\"/\3/' \ + --regex='/SCM_DEFINE[ \t]*(\([^,]*\),[^,]*/\1/' + SNARF = guile-snarf -SUFFIXES = .x .i +SUFFIXES = .i .x +.c.i: + grep '^VM_DEFINE' $< > $@ .c.x: - $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ + $(SNARF) $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } -.c.i: - grep '^SCM_DEFINE' $< > $@ - $(BUILT_SOURCES): config.h vm_expand.h - -guile-compile: guile-compile.in - sed -e 's!\@bindir\@!$(bindir)!' -e 's!\@PACKAGE\@!$(PACKAGE)!' \ - $< > $@ - -test: all - $(bin_PROGRAMS) -s test.scm - -debug-test: all - $(bin_PROGRAMS) -s test.scm debug diff --git a/src/envs.c b/src/envs.c new file mode 100644 index 000000000..a6c12bdea --- /dev/null +++ b/src/envs.c @@ -0,0 +1,250 @@ +/* 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. */ + +#include +#include "envs.h" + +#define ENV_OBARRAY_SIZE 31 + + +scm_bits_t scm_tc16_env; + +SCM +scm_c_make_env (void) +{ + struct scm_env *p = scm_must_malloc (sizeof (struct scm_env), + "scm_c_make_env"); + p->identifier = SCM_BOOL_F; + p->obarray = scm_c_make_hash_table (ENV_OBARRAY_SIZE); + SCM_RETURN_NEWSMOB (scm_tc16_env, p); +} + +static SCM +env_mark (SCM obj) +{ + struct scm_env *p = SCM_ENV_DATA (obj); + scm_gc_mark (p->identifier); + return p->obarray; +} + +static scm_sizet +env_free (SCM obj) +{ + scm_must_free (SCM_ENV_DATA (obj)); + return sizeof (struct scm_env); +} + + +/* + * C interface + */ + +static SCM env_table; +static SCM load_env; + +SCM +scm_c_lookup_env (SCM identifier) +{ + /* Check if the env is already loaded */ + SCM vcell = scm_sym2ovcell_soft (identifier, env_table); + + /* If not, load the env */ + if (SCM_FALSEP (vcell)) + { + SCM env = scm_apply (SCM_CDR (load_env), + SCM_LIST1 (identifier), SCM_EOL); + if (!SCM_ENV_P (env)) + scm_misc_error ("scm_c_lookup_env", + "Invalid env: ~S", SCM_LIST1 (env)); + scm_intern_symbol (env_table, identifier); + vcell = scm_sym2ovcell_soft (identifier, env_table); + SCM_SETCDR (vcell, env); + } + + return SCM_CDR (vcell); +} + +SCM +scm_c_env_vcell (SCM env, SCM name, int intern) +{ + SCM ob = SCM_ENV_OBARRAY (env); + if (intern) + scm_intern_symbol (ob, name); + return scm_sym2ovcell_soft (name, ob); +} + + +/* + * Scheme interface + */ + +SCM_DEFINE (scm_make_env, "make-env", 0, 0, 0, + (), + "") +#define FUNC_NAME s_scm_make_env +{ + return scm_c_make_env (); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_env_p, "env?", 1, 0, 0, + (SCM x), + "") +#define FUNC_NAME s_scm_env_p +{ + return SCM_BOOL (SCM_ENV_P (x)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_env_identifier, "env-identifier", 1, 0, 0, + (SCM env), + "") +#define FUNC_NAME s_scm_env_identifier +{ + SCM_VALIDATE_ENV (1, env); + return SCM_ENV_IDENTIFIER (env); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_env_identifier_x, "set-env-identifier!", 2, 0, 0, + (SCM env, SCM identifier), + "") +#define FUNC_NAME s_scm_set_env_identifier_x +{ + SCM_VALIDATE_ENV (1, env); + SCM_VALIDATE_SYMBOL (2, identifier); + SCM_ENV_IDENTIFIER (env) = identifier; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_env_bound_p, "env-bound?", 2, 0, 0, + (SCM env, SCM name), + "") +#define FUNC_NAME s_scm_env_bound_p +{ + SCM vcell; + SCM_VALIDATE_ENV (1, env); + SCM_VALIDATE_SYMBOL (2, name); + vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env)); + return SCM_BOOL (!SCM_FALSEP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_env_ref, "env-ref", 2, 0, 0, + (SCM env, SCM name), + "") +#define FUNC_NAME s_scm_env_ref +{ + SCM vcell; + SCM_VALIDATE_ENV (1, env); + SCM_VALIDATE_SYMBOL (2, name); + vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env)); + if (SCM_FALSEP (vcell) || SCM_UNBNDP (SCM_CDR (vcell))) + SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A", + SCM_LIST2 (env, name)); + return SCM_CDR (vcell); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_env_set_x, "env-set!", 3, 0, 0, + (SCM env, SCM name, SCM val), + "") +#define FUNC_NAME s_scm_env_set_x +{ + SCM vcell; + SCM_VALIDATE_ENV (1, env); + SCM_VALIDATE_SYMBOL (2, name); + vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env)); + if (SCM_FALSEP (vcell)) + SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A", + SCM_LIST2 (env, name)); + SCM_SETCDR (vcell, val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_env_define, "env-define", 3, 0, 0, + (SCM env, SCM name, SCM val), + "") +#define FUNC_NAME s_scm_env_define +{ + SCM vcell; + SCM_VALIDATE_ENV (1, env); + SCM_VALIDATE_SYMBOL (2, name); + vcell = scm_c_env_vcell (env, name, 1); + SCM_SETCDR (vcell, val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +void +scm_init_envs (void) +{ + SCM mod, old; + + scm_tc16_env = scm_make_smob_type ("env", 0); + scm_set_smob_mark (scm_tc16_env, env_mark); + scm_set_smob_free (scm_tc16_env, env_free); + + env_table = scm_permanent_object (scm_c_make_hash_table (51)); + + mod = scm_resolve_module (scm_read_0str ("(system base module)")); + old = scm_set_current_module (mod); + +#ifndef SCM_MAGIC_SNARFER +#include "envs.x" +#endif + + load_env = scm_eval_closure_lookup (scm_standard_eval_closure (mod), + scm_str2symbol ("load-env"), + SCM_BOOL_T); + load_env = SCM_VARVCELL (load_env); + + scm_set_current_module (old); +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/envs.h b/src/envs.h new file mode 100644 index 000000000..ddc5ea498 --- /dev/null +++ b/src/envs.h @@ -0,0 +1,73 @@ +/* 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 _ENVS_H_ +#define _ENVS_H_ + +#include +#include "config.h" + +extern scm_bits_t scm_tc16_env; + +struct scm_env { + SCM identifier; + SCM obarray; +}; + +#define SCM_ENV_P(x) SCM_SMOB_PREDICATE (scm_tc16_env, x) +#define SCM_ENV_DATA(x) ((struct scm_env *) SCM_SMOB_DATA (x)) +#define SCM_VALIDATE_ENV(p,x) SCM_MAKE_VALIDATE (p, x, ENV_P) + +#define SCM_ENV_IDENTIFIER(x) (SCM_ENV_DATA(x)->identifier) +#define SCM_ENV_OBARRAY(x) (SCM_ENV_DATA(x)->obarray) + +extern SCM scm_c_lookup_env (SCM identifier); +extern SCM scm_c_env_vcell (SCM env, SCM name, int intern); + +extern void scm_init_envs (void); + +#endif /* _ENVS_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/guile-compile.in b/src/guile-compile.in deleted file mode 100644 index 1589d220e..000000000 --- a/src/guile-compile.in +++ /dev/null @@ -1,6 +0,0 @@ -#!@bindir@/@PACKAGE@ -s -!# - -(use-modules (vm compile)) - -(for-each compile-file (cdr (command-line))) diff --git a/src/guile-vm.c b/src/guile-vm.c index 5d3c1c1a6..581c30a88 100644 --- a/src/guile-vm.c +++ b/src/guile-vm.c @@ -41,18 +41,10 @@ #include -extern void scm_init_vm_vm_module (); - -static void -inner_main (void *closure, int argc, char **argv) -{ - scm_init_vm_vm_module (); - scm_shell (argc, argv); -} - int main (int argc, char **argv) { - scm_boot_guile (argc, argv, inner_main, 0); + scm_init_guile (); + scm_shell (argc, argv); return 0; /* never reached */ } diff --git a/src/instructions.c b/src/instructions.c new file mode 100644 index 000000000..fc5147b74 --- /dev/null +++ b/src/instructions.c @@ -0,0 +1,138 @@ +/* Copyright (C) 2000 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. */ + +#include +#include "instructions.h" + +struct scm_instruction scm_instruction_table[] = { +#define VM_INSTRUCTION_TO_TABLE 1 +#include "vm_expand.h" +#include "vm_system.i" +#include "vm_scheme.i" +#include "vm_number.i" +#include "vm_loader.i" +#undef VM_INSTRUCTION_TO_TABLE + {scm_op_last} +}; + +/* C interface */ + +struct scm_instruction * +scm_lookup_instruction (SCM name) +{ + struct scm_instruction *ip; + if (SCM_SYMBOLP (name)) + for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++) + if (strcmp (ip->name, SCM_SYMBOL_CHARS (name)) == 0) + return ip; + return 0; +} + +/* Scheme interface */ + +SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_instruction_list +{ + SCM list = SCM_EOL; + struct scm_instruction *ip; + for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++) + list = scm_cons (scm_str2symbol (ip->name), list); + return scm_reverse_x (list, SCM_EOL); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_instruction_p +{ + return SCM_BOOL (SCM_INSTRUCTION_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_length +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_MAKINUM (SCM_INSTRUCTION_LEN (inst)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_to_opcode +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_MAKINUM (SCM_INSTRUCTION_OPCODE (inst)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0, + (SCM op), + "") +#define FUNC_NAME s_scm_opcode_to_instruction +{ + int i; + SCM_VALIDATE_INUM (1, op); + i = SCM_INUM (op); + SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last); + return scm_str2symbol (scm_instruction_table[i].name); +} +#undef FUNC_NAME + +void +scm_init_instructions (void) +{ +#ifndef SCM_MAGIC_SNARFER +#include "instructions.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/instructions.h b/src/instructions.h new file mode 100644 index 000000000..425d1a34e --- /dev/null +++ b/src/instructions.h @@ -0,0 +1,84 @@ +/* Copyright (C) 2000 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 _INSTRUCTIONS_H_ +#define _INSTRUCTIONS_H_ + +#include +#include "config.h" + +enum scm_opcode { +#define VM_INSTRUCTION_TO_OPCODE 1 +#include "vm_expand.h" +#include "vm_system.i" +#include "vm_scheme.i" +#include "vm_number.i" +#include "vm_loader.i" +#undef VM_INSTRUCTION_TO_OPCODE + scm_op_last +}; + +struct scm_instruction { + enum scm_opcode opcode; /* opcode */ + char *name; /* instruction name */ + char len; /* byte length */ +}; + +#define SCM_INSTRUCTION_P(x) (scm_lookup_instruction (x)) +#define SCM_INSTRUCTION_OPCODE(i) (scm_lookup_instruction (i)->opcode) +#define SCM_INSTRUCTION_NAME(i) (scm_lookup_instruction (i)->name) +#define SCM_INSTRUCTION_LEN(i) (scm_lookup_instruction (i)->len) +#define SCM_VALIDATE_INSTRUCTION(p,x) SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P) + +#define SCM_INSTRUCTION(i) (&scm_instruction_table[i]) + +extern struct scm_instruction scm_instruction_table[]; +extern struct scm_instruction *scm_lookup_instruction (SCM name); + +extern void scm_init_instructions (void); + +#endif /* _INSTRUCTIONS_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/programs.c b/src/programs.c new file mode 100644 index 000000000..93ba54ab8 --- /dev/null +++ b/src/programs.c @@ -0,0 +1,209 @@ +/* Copyright (C) 2000 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. */ + +#include +#include "instructions.h" +#include "programs.h" +#include "vm.h" + + +scm_bits_t scm_tc16_program; + +static SCM zero_vector; + +SCM +scm_c_make_program (void *addr, size_t size, SCM holder) +#define FUNC_NAME "scm_c_make_program" +{ + struct scm_program *p = SCM_MUST_MALLOC (sizeof (struct scm_program)); + p->size = size; + p->nargs = 0; + p->nrest = 0; + p->nlocs = 0; + p->meta = SCM_EOL; + p->objs = zero_vector; + p->external = SCM_EOL; + p->holder = holder; + + /* If nobody holds bytecode's address, then allocate a new memory */ + if (SCM_FALSEP (p->holder)) + p->base = SCM_MUST_MALLOC (size); + else + p->base = addr; + + SCM_RETURN_NEWSMOB (scm_tc16_program, p); +} +#undef FUNC_NAME + +SCM +scm_c_make_vclosure (SCM program, SCM external) +{ + struct scm_program *p; + struct scm_program *q = SCM_PROGRAM_DATA (program); + SCM prog = scm_c_make_program (q->base, q->size, program); + p = SCM_PROGRAM_DATA (prog); + p->nargs = q->nargs; + p->nrest = q->nrest; + p->nlocs = q->nlocs; + p->meta = q->meta; + p->objs = q->objs; + p->external = external; + return prog; +} + +static SCM +program_mark (SCM obj) +{ + struct scm_program *p = SCM_PROGRAM_DATA (obj); + scm_gc_mark (p->meta); + scm_gc_mark (p->objs); + scm_gc_mark (p->external); + return p->holder; +} + +static scm_sizet +program_free (SCM obj) +{ + struct scm_program *p = SCM_PROGRAM_DATA (obj); + scm_sizet size = (sizeof (struct scm_program)); + if (SCM_FALSEP (p->holder)) + { + size += p->size; + scm_must_free (p->base); + } + scm_must_free (p); + return size; +} + +static int +program_print (SCM obj, SCM port, scm_print_state *pstate) +{ + scm_puts ("#', port); + return 1; +} + +static SCM +program_apply (SCM program, SCM args) +{ + return scm_vm_apply (scm_make_vm (), program, args); +} + + +/* + * 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_arity, "program-arity", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_arity +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_LIST3 (SCM_MAKINUM (SCM_PROGRAM_NARGS (program)), + SCM_MAKINUM (SCM_PROGRAM_NREST (program)), + SCM_MAKINUM (SCM_PROGRAM_NLOCS (program))); +} +#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_OBJS (program); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_external +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_EXTERNAL (program); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_bytecode +{ + SCM_VALIDATE_PROGRAM (1, program); + return scm_makfromstr (SCM_PROGRAM_BASE (program), + SCM_PROGRAM_SIZE (program), 0); +} +#undef FUNC_NAME + + +void +scm_init_programs (void) +{ + zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F)); + + scm_tc16_program = scm_make_smob_type ("program", 0); + scm_set_smob_mark (scm_tc16_program, program_mark); + scm_set_smob_free (scm_tc16_program, program_free); + scm_set_smob_print (scm_tc16_program, program_print); + scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1); + +#ifndef SCM_MAGIC_SNARFER +#include "programs.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/programs.h b/src/programs.h new file mode 100644 index 000000000..e1b2b3e9b --- /dev/null +++ b/src/programs.h @@ -0,0 +1,94 @@ +/* Copyright (C) 2000 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 _PROGRAM_H_ +#define _PROGRAM_H_ + +#include +#include "config.h" + +/* + * Programs + */ + +typedef unsigned char scm_byte_t; + +struct scm_program { + size_t size; /* the size of the program */ + unsigned char nargs; /* the number of arguments */ + unsigned char nrest; /* have a rest argument or not */ + unsigned short nlocs; /* the number of local variables */ + scm_byte_t *base; /* program base address */ + SCM meta; /* meta information */ + SCM objs; /* constant objects */ + SCM external; /* external environment */ + SCM holder; /* the owner of bytecode */ +}; + +extern scm_bits_t scm_tc16_program; + +#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x)) +#define SCM_PROGRAM_DATA(x) ((struct scm_program *) SCM_SMOB_DATA (x)) +#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) + +#define SCM_PROGRAM_SIZE(x) (SCM_PROGRAM_DATA (x)->size) +#define SCM_PROGRAM_NARGS(x) (SCM_PROGRAM_DATA (x)->nargs) +#define SCM_PROGRAM_NREST(x) (SCM_PROGRAM_DATA (x)->nrest) +#define SCM_PROGRAM_NLOCS(x) (SCM_PROGRAM_DATA (x)->nlocs) +#define SCM_PROGRAM_BASE(x) (SCM_PROGRAM_DATA (x)->base) +#define SCM_PROGRAM_META(x) (SCM_PROGRAM_DATA (x)->meta) +#define SCM_PROGRAM_OBJS(x) (SCM_PROGRAM_DATA (x)->objs) +#define SCM_PROGRAM_LINKS(x) (SCM_PROGRAM_DATA (x)->links) +#define SCM_PROGRAM_EXTERNAL(x) (SCM_PROGRAM_DATA (x)->external) +#define SCM_PROGRAM_HOLDER(x) (SCM_PROGRAM_DATA (x)->holder) + +extern SCM scm_c_make_program (void *addr, size_t size, SCM holder); +extern SCM scm_c_make_vclosure (SCM program, SCM external); + +extern void scm_init_programs (void); + +#endif /* _PROGRAM_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/test.scm b/src/test.scm deleted file mode 100644 index 85d747fea..000000000 --- a/src/test.scm +++ /dev/null @@ -1,60 +0,0 @@ - -(set! %load-path (cons ".." %load-path)) -(use-modules (vm vm)) -(use-modules (vm shell)) -(use-modules (vm compile)) -(use-modules (ice-9 syncase)) - -(define *verbose-output* (if (null? (cdr (command-line))) #f #t)) - -(define test-list - '((1 1) - ((1- 1) 0) - ((+ (+ 1) (- 2)) -1) - ((+ (+ 1 2) (- 1 2) (* 1 2) (/ 1 2)) 4.5) - ((* (- 1 2 3) (+ 1.2 3.4) (/ 1 2 4)) -2.3) - ((let ((a 1)) a) 1) - ((let ((a 1) (b 2)) b) 2) - ((let* ((a 1) (a 2)) a) 2) - ((let ((a 1)) (let ((b 2)) a)) 1) - ((let ((a 1) (b 2) (c 3)) - ((lambda (d e f) - ((lambda (g h i) - ((lambda () (list a b d f h i)))) - 7 8 9)) - 4 5 6)) - (1 2 4 6 8 9)) - ((do ((i 3 (1- i)) (n 0 (+ n i))) ((< i 0) n)) 6) - ((let () (define (foo a) a) (foo 1)) 1) - ((begin (define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) - (fib 3)) 2) - ((begin (define (loop i l) (if (< i l) (loop (+ 1 i) l) l)) - (loop 0 3)) 3) -; ((call-with-current-continuation (lambda (c) (c 1) 2)) 1) - ((map 1+ '(1 2 3)) (2 3 4)) - )) - -(define (test vm form answer) - (format #t "Testing ~S = ~S ..." form answer) - (let ((result (vm-run vm (compile form)))) - (if (equal? result answer) - (display "OK\n") - (format #t "failed: ~S\n" result)))) - -(define (debug-test vm form answer) - (format #t "Testing ~S = ~S ...\n" form answer) - (let ((result (begin - (vm-set-option! vm 'verbose *verbose-output*) - (vm-trace vm form)))) - (if (equal? result answer) - (display "OK\n") - (format #t "failed: ~S\n" result)))) - -(let ((vm (make-vm))) - (display "=== Testing the debug engine ===\n") - (vm-set-option! vm 'debug #t) - (for-each (lambda (q) (apply debug-test vm q)) test-list) - (display "\n=== Testing the fast engine ===\n") - (vm-set-option! vm 'debug #f) - (for-each (lambda (q) (apply test vm q)) test-list) - (display "done\n")) diff --git a/src/vm.c b/src/vm.c index a784fae0c..e82c1cb7f 100644 --- a/src/vm.c +++ b/src/vm.c @@ -39,14 +39,12 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -#define SCM_DEBUG_TYPING_STRICTNESS 0 -#include "config.h" +#include +#include "instructions.h" +#include "programs.h" +#include "envs.h" #include "vm.h" -/* default stack size in the number of SCM */ -#define VM_DEFAULT_STACK_SIZE (16 * 1024) /* = 64KB */ -#define VM_MAXIMUM_STACK_SIZE (1024 * 1024) /* = 4MB */ - /* I sometimes use this for debugging. */ #define vm_puts(OBJ) \ { \ @@ -56,722 +54,79 @@ /* - * Generic object name - */ - -static SCM scm_name_property; - -SCM_DEFINE (scm_name, "name", 1, 0, 0, - (SCM obj), -"") -#define FUNC_NAME s_scm_name -{ - return scm_primitive_property_ref (scm_name_property, obj); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_set_name_x, "set-name!", 2, 0, 0, - (SCM obj, SCM name), -"") -#define FUNC_NAME s_scm_set_name_x -{ - SCM_VALIDATE_SYMBOL (2, name); - return scm_primitive_property_set_x (scm_name_property, obj, name); -} -#undef FUNC_NAME - -int -scm_smob_print_with_name (SCM smob, SCM port, scm_print_state *pstate) -{ - int n = SCM_SMOBNUM (smob); - SCM name = scm_name (smob); - scm_puts ("#<", port); - scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); - scm_putc (' ', port); - if (SCM_FALSEP (name)) - { - scm_puts ("0x", port); - scm_intprint (SCM_UNPACK (scm_smobs[n].size ? SCM_CDR (smob) : smob), - 16, port); - } - else - { - scm_display (name, port); - } - scm_putc ('>', port); - return 1; -} - -static void -init_name_property () -{ - scm_name_property - = scm_permanent_object (scm_primitive_make_property (SCM_BOOL_F)); -} - - -/* - * Instruction + * VM Debug frame */ -static long scm_instruction_tag; - -static struct scm_instruction scm_instruction_table[] = { -#define VM_INSTRUCTION_TO_TABLE -#include "vm_expand.h" -#include "vm_system.i" -#include "vm_scheme.i" -#include "vm_number.i" -#undef VM_INSTRUCTION_TO_TABLE - {op_last} -}; - -#define SCM_INSTRUCTION(OP) &scm_instruction_table[SCM_UNPACK (OP)] +scm_bits_t scm_tc16_vm_debug_frame; static SCM -make_instruction (struct scm_instruction *instp) -{ - SCM_RETURN_NEWSMOB (scm_instruction_tag, instp); -} - -static int -print_instruction (SCM obj, SCM port, scm_print_state *pstate) -{ - scm_puts ("#name, port); - scm_putc ('>', port); - return 1; -} - -static void -init_instruction_type () -{ - scm_instruction_tag = scm_make_smob_type ("instruction", 0); - scm_set_smob_print (scm_instruction_tag, print_instruction); -} - -/* C interface */ - -static struct scm_instruction * -scm_lookup_instruction (const char *name) -{ - struct scm_instruction *p; - for (p = scm_instruction_table; p->opcode != op_last; p++) - if (strcmp (name, p->name) == 0) - return p; - return 0; -} - -/* Scheme interface */ - -SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0, - (SCM obj), -"") -#define FUNC_NAME s_scm_instruction_p -{ - return SCM_BOOL (SCM_INSTRUCTION_P (obj)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_system_instruction_p, "system-instruction?", 1, 0, 0, - (SCM obj), -"") -#define FUNC_NAME s_scm_system_instruction_p -{ - return SCM_BOOL (SCM_SYSTEM_INSTRUCTION_P (obj)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_functional_instruction_p, "functional-instruction?", 1, 0, 0, - (SCM obj), -"") -#define FUNC_NAME s_scm_functional_instruction_p -{ - return SCM_BOOL (SCM_FUNCTIONAL_INSTRUCTION_P (obj)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_name_p, "instruction-name?", 1, 0, 0, - (SCM name), -"") -#define FUNC_NAME s_scm_instruction_name_p -{ - SCM_VALIDATE_SYMBOL (1, name); - return SCM_BOOL (scm_lookup_instruction (SCM_SYMBOL_CHARS (name))); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_symbol_to_instruction, "symbol->instruction", 1, 0, 0, - (SCM name), -"") -#define FUNC_NAME s_scm_symbol_to_instruction -{ - struct scm_instruction *p; - SCM_VALIDATE_SYMBOL (1, name); - - p = scm_lookup_instruction (SCM_SYMBOL_CHARS (name)); - if (!p) - SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name)); - - return p->obj; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, - (), -"") -#define FUNC_NAME s_scm_instruction_list -{ - SCM list = SCM_EOL; - struct scm_instruction *p; - for (p = scm_instruction_table; p->opcode != op_last; p++) - list = scm_cons (p->obj, list); - return scm_reverse_x (list, SCM_EOL); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_opcode, "instruction-opcode", 1, 0, 0, - (SCM inst), -"") -#define FUNC_NAME s_scm_instruction_opcode +make_vm_debug_frame (SCM *fp) { - SCM_VALIDATE_INSTRUCTION (1, inst); - return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->opcode); -} -#undef FUNC_NAME + int i, size; + struct scm_vm_debug_frame *p; -SCM_DEFINE (scm_instruction_name, "instruction-name", 1, 0, 0, - (SCM inst), -"") -#define FUNC_NAME s_scm_instruction_name -{ - SCM_VALIDATE_INSTRUCTION (1, inst); - return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->name)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_type, "instruction-type", 1, 0, 0, - (SCM inst), -"") -#define FUNC_NAME s_scm_instruction_type -{ - SCM_VALIDATE_INSTRUCTION (1, inst); - return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->type); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_scheme_name, "instruction-scheme-name", 1, 0, 0, - (SCM inst), -"") -#define FUNC_NAME s_scm_instruction_scheme_name -{ - SCM_VALIDATE_INSTRUCTION (1, inst); - if (SCM_FUNCTIONAL_INSTRUCTION_P (inst)) - return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->sname)); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_arity, "instruction-arity", 1, 0, 0, - (SCM inst), -"") -#define FUNC_NAME s_scm_instruction_arity -{ - SCM_VALIDATE_INSTRUCTION (1, inst); - if (SCM_FUNCTIONAL_INSTRUCTION_P (inst)) - { - struct scm_instruction *p = SCM_INSTRUCTION_DATA (inst); - return SCM_LIST2 (SCM_MAKINUM (p->nargs), SCM_BOOL (p->restp)); - } - else + if (!fp) return SCM_BOOL_F; -} -#undef FUNC_NAME - - -/* - * Bytecode - */ - -static long scm_bytecode_tag; - -static SCM -make_bytecode (int size) -{ - struct scm_bytecode *p - = scm_must_malloc (sizeof (*p) + (size * sizeof (SCM)), "make_bytecode"); - p->size = size; - SCM_RETURN_NEWSMOB (scm_bytecode_tag, p); -} - -static SCM -mark_bytecode (SCM bytecode) -{ - int i; - struct scm_instruction *p; - - int size = SCM_BYTECODE_SIZE (bytecode); - SCM *base = SCM_BYTECODE_BASE (bytecode); - - for (i = 0; i < size; i++) - { - p = SCM_INSTRUCTION (base[i]); - switch (p->type) - { - case INST_NONE: - break; - case INST_SCM: - case INST_TOP: - case INST_EXT: - case INST_CODE: - scm_gc_mark (base[++i]); - break; - case INST_INUM: /* a fixed integer; we don't need to mark it */ - case INST_ADDR: /* real memory address; we shouldn't mark it! */ - i++; - } - } - return SCM_BOOL_F; -} - -static int -print_bytecode (SCM obj, SCM port, scm_print_state *pstate) -{ - scm_puts ("#', port); - return 1; -} - -static scm_sizet -free_bytecode (SCM bytecode) -{ - int size = (sizeof (struct scm_bytecode) - + (SCM_BYTECODE_SIZE (bytecode) * sizeof (SCM))); - if (SCM_BYTECODE_EXTS (bytecode)) - { - size += (SCM_BYTECODE_EXTS (bytecode)[0] + 1) * sizeof (int); - scm_must_free (SCM_BYTECODE_EXTS (bytecode)); - } - scm_must_free (SCM_BYTECODE_DATA (bytecode)); - return size; -} - -static void -init_bytecode_type () -{ - scm_bytecode_tag = scm_make_smob_type ("bytecode", 0); - scm_set_smob_mark (scm_bytecode_tag, mark_bytecode); - scm_set_smob_print (scm_bytecode_tag, print_bytecode); - scm_set_smob_free (scm_bytecode_tag, free_bytecode); -} - -/* Internal functions */ - -static SCM -lookup_variable (SCM sym) -{ - SCM eclo = scm_standard_eval_closure (scm_selected_module ()); - SCM var = scm_eval_closure_lookup (eclo, sym, SCM_BOOL_F); - if (SCM_FALSEP (var)) - var = scm_eval_closure_lookup (eclo, sym, SCM_BOOL_T); - return var; -} - -/* Scheme interface */ - -SCM_DEFINE (scm_bytecode_p, "bytecode?", 1, 0, 0, - (SCM obj), -"") -#define FUNC_NAME s_scm_bytecode_p -{ - return SCM_BOOL (SCM_BYTECODE_P (obj)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0, - (SCM code), -"") -#define FUNC_NAME s_scm_make_bytecode -{ - int i, size, len, offset; - SCM header, body, nreqs, restp, nvars, nexts, exts, bytecode; - SCM *old, *new, *address; - - /* Type check */ - SCM_VALIDATE_VECTOR (1, code); - SCM_ASSERT_RANGE (1, code, SCM_LENGTH (code) == 2); - header = SCM_VELTS (code)[0]; - body = SCM_VELTS (code)[1]; - SCM_VALIDATE_VECTOR (1, header); - SCM_VALIDATE_VECTOR (2, body); - SCM_ASSERT_RANGE (1, header, SCM_LENGTH (header) == 5); - nreqs = SCM_VELTS (header)[0]; - restp = SCM_VELTS (header)[1]; - nvars = SCM_VELTS (header)[2]; - nexts = SCM_VELTS (header)[3]; - exts = SCM_VELTS (header)[4]; - SCM_VALIDATE_INUM (1, nreqs); - SCM_VALIDATE_BOOL (2, restp); - SCM_VALIDATE_INUM (3, nvars); - SCM_VALIDATE_INUM (4, nexts); - SCM_VALIDATE_VECTOR (5, exts); - - /* Create a new bytecode */ - size = SCM_LENGTH (body); - old = SCM_VELTS (body); - bytecode = make_bytecode (size); - new = SCM_BYTECODE_BASE (bytecode); - - /* Initialize the header */ - SCM_BYTECODE_NREQS (bytecode) = SCM_INUM (nreqs); - SCM_BYTECODE_RESTP (bytecode) = SCM_FALSEP (restp) ? 0 : 1; - SCM_BYTECODE_NVARS (bytecode) = SCM_INUM (nvars); - SCM_BYTECODE_NEXTS (bytecode) = SCM_INUM (nexts); - len = SCM_LENGTH (exts); - if (len == 0) - { - SCM_BYTECODE_EXTS (bytecode) = NULL; - } - else - { - SCM_BYTECODE_EXTS (bytecode) = - scm_must_malloc ((len + 1) * sizeof (int), FUNC_NAME); - SCM_BYTECODE_EXTS (bytecode)[0] = len; - for (i = 0; i < len; i++) - SCM_BYTECODE_EXTS (bytecode)[i + 1] = SCM_INUM (SCM_VELTS (exts)[i]); - } - - /* Initialize the body */ - for (i = 0; i < size; i++) - { - struct scm_instruction *p; - - /* Process instruction */ - if (!SCM_SYMBOLP (old[i]) - || !(p = scm_lookup_instruction (SCM_SYMBOL_CHARS (old[i])))) - SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old[i])); - new[i] = SCM_PACK (p->opcode); - - /* Process arguments */ - if (p->type == INST_NONE) - continue; - if (++i >= size) - SCM_MISC_ERROR ("Unexpected end of code", SCM_EOL); - switch (p->type) - { - case INST_NONE: - /* never come here */ - case INST_INUM: - SCM_VALIDATE_INUM (1, old[i]); - /* fall through */ - case INST_SCM: - /* just copy */ - new[i] = old[i]; - break; - case INST_TOP: - /* top-level variable */ - SCM_VALIDATE_SYMBOL (1, old[i]); - new[i] = lookup_variable (old[i]); - break; - case INST_EXT: - /* just copy for now */ - SCM_VALIDATE_CONS (1, old[i]); - SCM_VALIDATE_INUM (1, SCM_CAR (old[i])); - SCM_VALIDATE_INUM (1, SCM_CDR (old[i])); - new[i] = old[i]; - break; - case INST_CODE: - /* another bytecode */ - new[i] = scm_make_bytecode (old[i]); - break; - case INST_ADDR: - /* real address */ - SCM_VALIDATE_INUM (1, old[i]); - /* Without the following intermediate variables, type conversion - fails on my machine. Casting doesn't work well, why? */ - offset = SCM_INUM (old[i]); - address = new + offset; - new[i] = SCM_VM_MAKE_ADDRESS (address); - break; - } - } - return bytecode; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bytecode_decode, "bytecode-decode", 1, 0, 0, - (SCM bytecode), -"") -#define FUNC_NAME s_scm_bytecode_decode -{ - int i, size, offset; - SCM code, *old, *new; - - SCM_VALIDATE_BYTECODE (1, bytecode); - - size = SCM_BYTECODE_SIZE (bytecode); - old = SCM_BYTECODE_BASE (bytecode); - code = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); - new = SCM_VELTS (code); - - for (i = 0; i < size; i++) - { - struct scm_instruction *p; - - /* Process instruction */ - p = SCM_INSTRUCTION (old[i]); - if (!p) - { - broken: - SCM_MISC_ERROR ("Broken bytecode", SCM_EOL); - } - new[i] = scm_instruction_name (p->obj); - - /* Process arguments */ - if (p->type == INST_NONE) - continue; - if (++i >= size) - goto broken; - switch (p->type) - { - case INST_NONE: - /* never come here */ - case INST_INUM: - case INST_SCM: - case INST_EXT: - /* just copy */ - new[i] = old[i]; - break; - case INST_TOP: - /* top-level variable */ - new[i] = SCM_CAR (old[i]); - break; - case INST_CODE: - /* another bytecode */ - new[i] = scm_bytecode_decode (old[i]); - break; - case INST_ADDR: - /* program address */ - offset = SCM_VM_ADDRESS (old[i]) - old; - new[i] = SCM_MAKINUM (offset); - break; - } - } - return code; -} -#undef FUNC_NAME - - -/* - * Program - */ - -static long scm_program_tag; - -static SCM -make_program (SCM code, SCM env) -{ - SCM_RETURN_NEWSMOB2 (scm_program_tag, SCM_UNPACK (code), SCM_UNPACK (env)); -} - -static SCM -mark_program (SCM program) -{ - scm_gc_mark (SCM_PROGRAM_CODE (program)); - return SCM_PROGRAM_ENV (program); -} - -static SCM scm_vm_apply (SCM vm, SCM program, SCM args); -static SCM make_vm (int stack_size); - -static SCM -apply_program (SCM program, SCM args) -{ - return scm_vm_apply (make_vm (VM_DEFAULT_STACK_SIZE), program, args); -} - -static void -init_program_type () -{ - scm_program_tag = scm_make_smob_type ("program", 0); - scm_set_smob_mark (scm_program_tag, mark_program); - scm_set_smob_print (scm_program_tag, scm_smob_print_with_name); - scm_set_smob_apply (scm_program_tag, apply_program, 0, 0, 1); -} - -/* Scheme interface */ - -SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, - (SCM obj), -"") -#define FUNC_NAME s_scm_program_p -{ - return SCM_BOOL (SCM_PROGRAM_P (obj)); -} -#undef FUNC_NAME -SCM_DEFINE (scm_make_program, "make-program", 2, 0, 0, - (SCM bytecode, SCM parent), -"") -#define FUNC_NAME s_scm_make_program -{ - SCM_VALIDATE_BYTECODE (1, bytecode); - return make_program (bytecode, parent); -} -#undef FUNC_NAME + p = scm_must_malloc (sizeof (struct scm_vm_debug_frame), "make_vm_debug_frame"); + p->program = SCM_VM_FRAME_PROGRAM (fp); + p->dynamic_link = make_vm_debug_frame (SCM_VM_FRAME_ADDRESS + (SCM_VM_FRAME_DYNAMIC_LINK (fp))); -SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0, - (SCM program), -"") -#define FUNC_NAME s_scm_program_code -{ - SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_CODE (program); -} -#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_VM_MAKE_ADDRESS (SCM_PROGRAM_BASE (program)); -} -#undef FUNC_NAME - - -/* - * VM Frame - */ - -static long scm_vm_frame_tag; - -/* This is used for debugging */ -struct scm_vm_frame { - int size; - SCM program; - SCM variables; - SCM dynamic_link; - SCM external_link; - SCM stack_pointer; - SCM return_address; -}; - -#define SCM_VM_FRAME_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_frame_tag, OBJ) -#define SCM_VM_FRAME_DATA(FR) ((struct scm_vm_frame *) SCM_SMOB_DATA (FR)) -#define SCM_VALIDATE_VM_FRAME(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_FRAME_P) - -static SCM -make_vm_frame (SCM *fp) -{ - int i; - int size = SCM_INUM (SCM_VM_FRAME_SIZE (fp)); - struct scm_vm_frame *p = scm_must_malloc (sizeof (*p), "make_vm_frame"); - p->program = SCM_VM_FRAME_PROGRAM (fp); - p->dynamic_link = SCM_VM_FRAME_DYNAMIC_LINK (fp); - p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (fp); - p->stack_pointer = SCM_VM_FRAME_STACK_POINTER (fp); - p->return_address = SCM_VM_FRAME_RETURN_ADDRESS (fp); - - if (!SCM_FALSEP (p->dynamic_link)) - p->dynamic_link = make_vm_frame (SCM_VM_ADDRESS (p->dynamic_link)); - - size += SCM_PROGRAM_NREQS (p->program) + SCM_PROGRAM_RESTP (p->program); + size = SCM_PROGRAM_NARGS (p->program) + SCM_PROGRAM_NLOCS (p->program); p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); for (i = 0; i < size; i++) SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i); - SCM_RETURN_NEWSMOB (scm_vm_frame_tag, p); + SCM_RETURN_NEWSMOB (scm_tc16_vm_debug_frame, p); } static SCM -mark_vm_frame (SCM frame) -{ - struct scm_vm_frame *p = SCM_VM_FRAME_DATA (frame); - scm_gc_mark (p->program); - scm_gc_mark (p->dynamic_link); - scm_gc_mark (p->external_link); - return p->variables; -} - -static void -init_vm_frame_type () +vm_debug_frame_mark (SCM obj) { - scm_vm_frame_tag = scm_make_smob_type ("vm-frame", 0); - scm_set_smob_mark (scm_vm_frame_tag, mark_vm_frame); + scm_gc_mark (SCM_VM_DEBUG_FRAME_PROGRAM (obj)); + scm_gc_mark (SCM_VM_DEBUG_FRAME_VARIABLES (obj)); + return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (obj); } /* Scheme interface */ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, (SCM obj), -"") + "") #define FUNC_NAME s_scm_frame_p { - return SCM_BOOL (SCM_VM_FRAME_P (obj)); + return SCM_BOOL (SCM_VM_DEBUG_FRAME_P (obj)); } #undef FUNC_NAME SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0, (SCM frame), -"") + "") #define FUNC_NAME s_scm_frame_program { - SCM_VALIDATE_VM_FRAME (1, frame); - return SCM_VM_FRAME_DATA (frame)->program; + SCM_VALIDATE_VM_DEBUG_FRAME (1, frame); + return SCM_VM_DEBUG_FRAME_PROGRAM (frame); } #undef FUNC_NAME SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0, (SCM frame), -"") + "") #define FUNC_NAME s_scm_frame_variables { - SCM_VALIDATE_VM_FRAME (1, frame); - return SCM_VM_FRAME_DATA (frame)->variables; + SCM_VALIDATE_VM_DEBUG_FRAME (1, frame); + return SCM_VM_DEBUG_FRAME_VARIABLES (frame); } #undef FUNC_NAME SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, (SCM frame), -"") + "") #define FUNC_NAME s_scm_frame_dynamic_link { - SCM_VALIDATE_VM_FRAME (1, frame); - return SCM_VM_FRAME_DATA (frame)->dynamic_link; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0, - (SCM frame), -"") -#define FUNC_NAME s_scm_frame_external_link -{ - SCM_VALIDATE_VM_FRAME (1, frame); - return SCM_VM_FRAME_DATA (frame)->external_link; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0, - (SCM frame), -"") -#define FUNC_NAME s_scm_frame_stack_pointer -{ - SCM_VALIDATE_VM_FRAME (1, frame); - return SCM_VM_FRAME_DATA (frame)->stack_pointer; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, - (SCM frame), -"") -#define FUNC_NAME s_scm_frame_return_address -{ - SCM_VALIDATE_VM_FRAME (1, frame); - return SCM_VM_FRAME_DATA (frame)->return_address; + SCM_VALIDATE_VM_DEBUG_FRAME (1, frame); + return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (frame); } #undef FUNC_NAME @@ -780,7 +135,11 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, * VM Continuation */ -static long scm_vm_cont_tag; +scm_bits_t scm_tc16_vm_cont; + + +#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) +#define SCM_VM_CONT_VMP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT)) static SCM capture_vm_cont (struct scm_vm *vmp) @@ -789,12 +148,12 @@ capture_vm_cont (struct scm_vm *vmp) p->stack_size = vmp->stack_limit - vmp->sp; p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM), "capture_vm_cont"); - p->stack_limit = p->stack_base + p->stack_size - 1; - p->pc = vmp->pc; + p->stack_limit = p->stack_base + p->stack_size - 2; + p->ip = vmp->ip; p->sp = (SCM *) (vmp->stack_limit - vmp->sp); p->fp = (SCM *) (vmp->stack_limit - vmp->fp); memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM)); - SCM_RETURN_NEWSMOB (scm_vm_cont_tag, p); + SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p); } static void @@ -803,20 +162,20 @@ reinstate_vm_cont (struct scm_vm *vmp, SCM cont) struct scm_vm *p = SCM_VM_CONT_VMP (cont); if (vmp->stack_size < p->stack_size) { - puts ("FIXME: Need to expand"); + /* puts ("FIXME: Need to expand"); */ abort (); } - vmp->pc = p->pc; + vmp->ip = p->ip; vmp->sp = vmp->stack_limit - (int) p->sp; vmp->fp = vmp->stack_limit - (int) p->fp; memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM)); } static SCM -mark_vm_cont (SCM cont) +vm_cont_mark (SCM obj) { SCM *p; - struct scm_vm *vmp = SCM_VM_CONT_VMP (cont); + struct scm_vm *vmp = SCM_VM_CONT_VMP (obj); for (p = vmp->stack_base; p <= vmp->stack_limit; p++) if (SCM_NIMP (*p)) scm_gc_mark (*p); @@ -824,21 +183,34 @@ mark_vm_cont (SCM cont) } static scm_sizet -free_vm_cont (SCM cont) +vm_cont_free (SCM obj) { - struct scm_vm *p = SCM_VM_CONT_VMP (cont); + struct scm_vm *p = SCM_VM_CONT_VMP (obj); int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM); scm_must_free (p->stack_base); scm_must_free (p); return size; } -static void -init_vm_cont_type () + +/* + * VM Internal functions + */ + +SCM_SYMBOL (sym_vm_engine, "vm-engine"); +SCM_SYMBOL (sym_vm_error, "vm-error"); + +static scm_byte_t * +vm_fetch_length (scm_byte_t *ip, size_t *lenp) { - scm_vm_cont_tag = scm_make_smob_type ("vm-cont", 0); - scm_set_smob_mark (scm_vm_cont_tag, mark_vm_cont); - scm_set_smob_free (scm_vm_cont_tag, free_vm_cont); + *lenp = *ip++; + if (*lenp < 254) + return ip; + else if (*lenp == 254) + *lenp = (*ip++ << 8) + *ip++; + else + *lenp = (*ip++ << 24) + (*ip++ << 16) + (*ip++ << 8) + *ip++; + return ip; } @@ -846,61 +218,109 @@ init_vm_cont_type () * VM */ -static long scm_vm_tag; +#define VM_DEFAULT_STACK_SIZE (16 * 1024) +#define VM_MAXIMUM_STACK_SIZE (128 * 1024) + +#define VM_REGULAR_ENGINE 0 +#define VM_DEBUG_ENGINE 1 + +#if 0 +#define VM_NAME vm_regular_engine +#define VM_ENGINE VM_REGULAR_ENGINE +#include "vm_engine.c" +#undef VM_NAME +#undef VM_ENGINE +#endif + +#define VM_NAME vm_debug_engine +#define VM_ENGINE VM_DEBUG_ENGINE +#include "vm_engine.c" +#undef VM_NAME +#undef VM_ENGINE + +scm_bits_t scm_tc16_vm; static SCM -make_vm (int stack_size) +make_vm (void) +#define FUNC_NAME "make_vm" { - struct scm_vm *vmp = scm_must_malloc (sizeof (struct scm_vm), "make_vm"); - vmp->stack_size = stack_size; - vmp->stack_base = scm_must_malloc (stack_size * sizeof (SCM), "make_vm"); + int i; + struct scm_vm *vmp = SCM_MUST_MALLOC (sizeof (struct scm_vm)); + vmp->stack_size = VM_DEFAULT_STACK_SIZE; + vmp->stack_base = SCM_MUST_MALLOC (vmp->stack_size * sizeof (SCM)); vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1; + vmp->ip = NULL; vmp->sp = vmp->stack_limit; - vmp->ac = SCM_BOOL_F; - vmp->pc = NULL; vmp->fp = NULL; + vmp->cons = 0; + vmp->time = 0; + vmp->clock = 0; vmp->options = SCM_EOL; - vmp->boot_hook = scm_make_hook (SCM_MAKINUM (1)); - vmp->halt_hook = scm_make_hook (SCM_MAKINUM (1)); - vmp->next_hook = scm_make_hook (SCM_MAKINUM (1)); - vmp->call_hook = scm_make_hook (SCM_MAKINUM (1)); - vmp->apply_hook = scm_make_hook (SCM_MAKINUM (1)); - vmp->return_hook = scm_make_hook (SCM_MAKINUM (1)); - SCM_RETURN_NEWSMOB (scm_vm_tag, vmp); + for (i = 0; i < SCM_VM_NUM_HOOKS; i++) + vmp->hooks[i] = SCM_BOOL_F; + SCM_RETURN_NEWSMOB (scm_tc16_vm, vmp); } +#undef FUNC_NAME static SCM -mark_vm (SCM vm) +vm_mark (SCM obj) { - SCM *p; - struct scm_vm *vmp = SCM_VM_DATA (vm); - for (p = vmp->sp + 1; p <= vmp->stack_limit; p++) - if (SCM_NIMP (*p)) - scm_gc_mark (*p); + int i; + SCM *sp, *fp; + struct scm_vm *vmp = SCM_VM_DATA (obj); + + /* Mark the stack */ + sp = vmp->sp; + fp = vmp->fp; + while (fp) + { + SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp); + SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp); + /* Mark intermediate data */ + for (; sp < lower; sp++) + if (SCM_NIMP (*sp)) + scm_gc_mark (*sp); + /* Mark frame data */ + scm_gc_mark (SCM_VM_FRAME_PROGRAM (fp)); + /* Mark frame variables */ + for (sp = fp; sp < upper; sp++) + if (SCM_NIMP (*sp)) + scm_gc_mark (*sp); + fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp)); + } - scm_gc_mark (vmp->ac); - scm_gc_mark (vmp->boot_hook); - scm_gc_mark (vmp->halt_hook); - scm_gc_mark (vmp->next_hook); - scm_gc_mark (vmp->call_hook); - scm_gc_mark (vmp->apply_hook); - scm_gc_mark (vmp->return_hook); + /* Mark the options */ + for (i = 0; i < SCM_VM_NUM_HOOKS; i++) + scm_gc_mark (vmp->hooks[i]); return vmp->options; } -static void -init_vm_type () +static scm_sizet +vm_free (SCM obj) +{ + struct scm_vm *vmp = SCM_VM_DATA (obj); + int size = (sizeof (struct scm_vm) + vmp->stack_size * sizeof (SCM)); + scm_must_free (vmp->stack_base); + scm_must_free (vmp); + return size; +} + +SCM_SYMBOL (sym_debug, "debug"); + +SCM +scm_vm_apply (SCM vm, SCM program, SCM args) +#define FUNC_NAME "scm_vm_apply" { - scm_vm_tag = scm_make_smob_type ("vm", sizeof (struct scm_vm)); - scm_set_smob_mark (scm_vm_tag, mark_vm); - scm_set_smob_print (scm_vm_tag, scm_smob_print_with_name); + SCM_VALIDATE_PROGRAM (1, program); + return vm_engine (vm, program, args); } +#undef FUNC_NAME /* Scheme interface */ SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, - (), -"") + (void), + "") #define FUNC_NAME s_scm_vm_version { return scm_makfrom0str (VERSION); @@ -909,7 +329,7 @@ SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, 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)); @@ -917,345 +337,267 @@ SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0, - (), -"") -#define FUNC_NAME s_scm_make_vm + (void), + "") +#define FUNC_NAME s_scm_make_vm, { - return make_vm (VM_DEFAULT_STACK_SIZE); + return make_vm (); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_ac, "vm:ac", 1, 0, 0, +SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, (SCM vm), -"") -#define FUNC_NAME s_scm_vm_ac + "") +#define FUNC_NAME s_scm_vm_ip { SCM_VALIDATE_VM (1, vm); - return SCM_VM_DATA (vm)->ac; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_vm_pc, "vm:pc", 1, 0, 0, - (SCM vm), -"") -#define FUNC_NAME s_scm_vm_pc -{ - SCM_VALIDATE_VM (1, vm); - return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->pc); + return scm_ulong2num ((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_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->sp); + return scm_ulong2num ((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_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->fp); + return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->fp); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0, +#define VM_DEFINE_HOOK(n) \ +{ \ + struct scm_vm *vmp; \ + SCM_VALIDATE_VM (1, vm); \ + vmp = SCM_VM_DATA (vm); \ + if (SCM_FALSEP (vmp->hooks[n])) \ + vmp->hooks[n] = scm_make_hook (SCM_MAKINUM (1)); \ + return vmp->hooks[n]; \ +} + +SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0, (SCM vm), -"") -#define FUNC_NAME s_scm_vm_current_frame + "") +#define FUNC_NAME s_scm_vm_boot_hook { - SCM_VALIDATE_VM (1, vm); - return make_vm_frame (SCM_VM_DATA (vm)->fp); + VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 2, 0, 0, - (SCM vm, SCM addr), -"") -#define FUNC_NAME s_scm_vm_fetch_code +SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_halt_hook { - SCM *p, list; - struct scm_instruction *inst; - - SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_INUM (2, addr); - - p = SCM_VM_ADDRESS (addr); - - inst = SCM_INSTRUCTION (*p); - if (!inst) - SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr)); - - list = SCM_LIST1 (scm_instruction_name (inst->obj)); - if (inst->type != INST_NONE) - { - if (inst->type == INST_ADDR) - { - p = SCM_CODE_TO_ADDR (p[1]); - SCM_SETCDR (list, SCM_LIST1 (SCM_VM_MAKE_ADDRESS (p))); - } - else - SCM_SETCDR (list, SCM_LIST1 (p[1])); - } - return list; + VM_DEFINE_HOOK (SCM_VM_HALT_HOOK); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_stack_to_list, "vm-stack->list", 1, 0, 0, +SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, (SCM vm), -"") -#define FUNC_NAME s_scm_vm_stack_to_list + "") +#define FUNC_NAME s_scm_vm_next_hook { - struct scm_vm *vmp; - SCM *p, list = SCM_EOL; - - SCM_VALIDATE_VM (1, vm); - - vmp = SCM_VM_DATA (vm); - for (p = vmp->sp + 1; p <= vmp->stack_limit; p++) - list = scm_cons (*p, list); - return list; + VM_DEFINE_HOOK (SCM_VM_NEXT_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_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_enter_hook { - SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_SYMBOL (2, key); - return scm_assq_ref (SCM_VM_DATA (vm)->options, key); + VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_set_option_x, "vm-set-option!", 3, 0, 0, - (SCM vm, SCM key, SCM val), -"") -#define FUNC_NAME s_scm_vm_set_option_x +SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_apply_hook { - SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_SYMBOL (2, key); - SCM_VM_DATA (vm)->options - = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val); - return SCM_UNSPECIFIED; + VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0, +SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0, (SCM vm), -"") -#define FUNC_NAME s_scm_vm_boot_hook + "") +#define FUNC_NAME s_scm_vm_exit_hook { - SCM_VALIDATE_VM (1, vm); - return SCM_VM_DATA (vm)->boot_hook; + VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0, +SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0, (SCM vm), -"") -#define FUNC_NAME s_scm_vm_halt_hook + "") +#define FUNC_NAME s_scm_vm_return_hook { - SCM_VALIDATE_VM (1, vm); - return SCM_VM_DATA (vm)->halt_hook; + VM_DEFINE_HOOK (SCM_VM_RETURN_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 +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_VM_DATA (vm)->next_hook; + return scm_assq_ref (SCM_VM_DATA (vm)->options, key); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_call_hook, "vm-call-hook", 1, 0, 0, - (SCM vm), -"") -#define FUNC_NAME s_scm_vm_call_hook +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); - return SCM_VM_DATA (vm)->call_hook; + 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_apply_hook, "vm-apply-hook", 1, 0, 0, +SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0, (SCM vm), -"") -#define FUNC_NAME s_scm_vm_apply_hook + "") +#define FUNC_NAME s_scm_vm_stats { + SCM stats; + SCM_VALIDATE_VM (1, vm); - return SCM_VM_DATA (vm)->apply_hook; + + stats = scm_c_make_vector (3, SCM_MAKINUM (0)); + SCM_VELTS (stats)[0] = scm_long2num (SCM_VM_DATA (vm)->cons); + SCM_VELTS (stats)[1] = scm_long2num (SCM_VM_DATA (vm)->time); + SCM_VELTS (stats)[2] = scm_long2num (SCM_VM_DATA (vm)->clock); + + return stats; } #undef FUNC_NAME -SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0, +#define VM_CHECK_RUNNING(vm) \ + if (!SCM_VM_DATA (vm)->ip) \ + SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm)) + +SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0, (SCM vm), -"") -#define FUNC_NAME s_scm_vm_return_hook + "") +#define FUNC_NAME s_scm_vm_current_frame { SCM_VALIDATE_VM (1, vm); - return SCM_VM_DATA (vm)->return_hook; + VM_CHECK_RUNNING (vm); + return make_vm_debug_frame (SCM_VM_DATA (vm)->fp); } #undef FUNC_NAME -SCM_SYMBOL (sym_debug, "debug"); +SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_fetch_code +{ + int i; + SCM list; + scm_byte_t *ip; + struct scm_instruction *p; -static SCM scm_regular_vm (SCM vm, SCM program); -static SCM scm_debug_vm (SCM vm, SCM program); + SCM_VALIDATE_VM (1, vm); + VM_CHECK_RUNNING (vm); -#define VM_CODE(name) SCM_PACK (scm_lookup_instruction (name)->opcode) + ip = SCM_VM_DATA (vm)->ip; + p = SCM_INSTRUCTION (*ip); -SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0, - (SCM vm, SCM program), -"") -#define FUNC_NAME s_scm_vm_run + list = SCM_LIST1 (scm_str2symbol (p->name)); + for (i = 1; i <= p->len; i++) + list = scm_cons (SCM_MAKINUM (ip[i]), list); + return scm_reverse_x (list, SCM_EOL); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_fetch_stack { - SCM bootcode; - static SCM template[5]; + SCM *p; + SCM list = SCM_EOL; SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_PROGRAM (2, program); + VM_CHECK_RUNNING (vm); - if (SCM_EQ_P (template[0], SCM_PACK (0))) - { - template[0] = VM_CODE ("%loadc"); - template[1] = SCM_BOOL_F; /* overwritten */ - template[2] = VM_CODE ("%call"); - template[3] = SCM_MAKINUM (0); - template[4] = VM_CODE ("%halt"); - } - - /* Create a boot program */ - bootcode = make_bytecode (5); - memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 5); - SCM_BYTECODE_BASE (bootcode)[1] = program; - SCM_BYTECODE_SIZE (bootcode) = 5; - SCM_BYTECODE_EXTS (bootcode) = NULL; - SCM_BYTECODE_NREQS (bootcode) = 0; - SCM_BYTECODE_RESTP (bootcode) = 0; - SCM_BYTECODE_NVARS (bootcode) = 0; - SCM_BYTECODE_NEXTS (bootcode) = 0; - program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F); - - if (SCM_FALSEP (scm_vm_option (vm, sym_debug))) - return scm_regular_vm (vm, program); - else - return scm_debug_vm (vm, program); + if (SCM_VM_DATA (vm)->fp) + for (p = SCM_VM_FRAME_LOWER_ADDRESS (SCM_VM_DATA (vm)->fp) - 1; + p >= SCM_VM_DATA (vm)->sp; + p--) + list = scm_cons (*p, list); + return list; } #undef FUNC_NAME -SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0, - (SCM vm, SCM program, SCM args), -"") -#define FUNC_NAME s_scm_vm_apply +SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0, + (SCM vm, SCM bytes), + "") +#define FUNC_NAME s_scm_vm_load { - int len; - SCM bootcode; - static SCM template[7]; + SCM prog; SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_PROGRAM (2, program); - SCM_VALIDATE_LIST_COPYLEN (3, args, len); + SCM_VALIDATE_STRING (2, bytes); - if (SCM_EQ_P (template[0], SCM_PACK (0))) - { - template[0] = VM_CODE ("%push-list"); - template[1] = SCM_EOL; /* overwritten */ - template[2] = VM_CODE ("%loadc"); - template[3] = SCM_BOOL_F; /* overwritten */ - template[4] = VM_CODE ("%call"); - template[5] = SCM_MAKINUM (0); /* overwritten */ - template[6] = VM_CODE ("%halt"); - } - - /* Create a boot program */ - bootcode = make_bytecode (7); - memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 7); - SCM_BYTECODE_BASE (bootcode)[1] = args; - SCM_BYTECODE_BASE (bootcode)[3] = program; - SCM_BYTECODE_BASE (bootcode)[5] = SCM_MAKINUM (len); - SCM_BYTECODE_SIZE (bootcode) = 7; - SCM_BYTECODE_EXTS (bootcode) = NULL; - SCM_BYTECODE_NREQS (bootcode) = 0; - SCM_BYTECODE_RESTP (bootcode) = 0; - SCM_BYTECODE_NVARS (bootcode) = 0; - SCM_BYTECODE_NEXTS (bootcode) = 0; - program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F); - - if (SCM_FALSEP (scm_vm_option (vm, sym_debug))) - return scm_regular_vm (vm, program); - else - return scm_debug_vm (vm, program); + prog = scm_c_make_program (SCM_STRING_CHARS (bytes), + SCM_STRING_LENGTH (bytes), + bytes); + return scm_vm_apply (vm, prog, SCM_EOL); } #undef FUNC_NAME /* - * The VM engines + * Initialize */ -/* We don't want to snarf the engines */ -#ifndef SCM_MAGIC_SNARFER - -/* the regular engine */ -#define VM_ENGINE SCM_VM_REGULAR_ENGINE -#include "vm_engine.c" -#undef VM_ENGINE +void +scm_init_vm (void) +{ + SCM mod = scm_resolve_module (scm_read_0str ("(system vm core)")); + mod = scm_set_current_module (mod); -/* the debug engine */ -#define VM_ENGINE SCM_VM_DEBUG_ENGINE -#include "vm_engine.c" -#undef VM_ENGINE + scm_init_instructions (); + scm_init_programs (); -#endif /* not SCM_MAGIC_SNARFER */ + scm_tc16_vm_debug_frame = scm_make_smob_type ("vm_frame", 0); + scm_set_smob_mark (scm_tc16_vm_debug_frame, vm_debug_frame_mark); - -/* - * Initialize - */ + 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); -static SCM scm_module_vm; + 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); -void -scm_init_vm () -{ - SCM old_module; - - /* Initialize the module */ - scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)")); - old_module = scm_select_module (scm_module_vm); - init_name_property (); - init_instruction_type (); - init_bytecode_type (); - init_program_type (); - init_vm_frame_type (); - init_vm_cont_type (); - init_vm_type (); +#ifndef SCM_MAGIC_SNARFER #include "vm.x" - scm_select_module (old_module); - - { - struct scm_instruction *p; - for (p = scm_instruction_table; p->opcode != op_last; p++) - { - p->obj = scm_permanent_object (make_instruction (p)); - if (p->restp) p->type = INST_INUM; - } - } -} +#endif -void -scm_init_vm_vm_module () -{ - scm_register_module_xxx ("vm vm", (void *) scm_init_vm); + scm_set_current_module (mod); } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/vm.h b/src/vm.h index 80f82467a..68d83087e 100644 --- a/src/vm.h +++ b/src/vm.h @@ -39,192 +39,118 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -#ifndef VM_H -#define VM_H +#ifndef _VM_H_ +#define _VM_H_ #include #include "config.h" +#include "programs.h" - /* - * Instruction + * VM Address */ -/* Opcode */ -enum scm_opcode { -#define VM_INSTRUCTION_TO_OPCODE -#include "vm_expand.h" -#include "vm_system.i" -#include "vm_scheme.i" -#include "vm_number.i" -#undef VM_INSTRUCTION_TO_OPCODE - op_last -}; - -/* Argument type */ -/* Modify `mark_bytecode', `scm_make_bytecode', and `scm_bytecode_decode'! */ -enum scm_inst_type { - INST_NONE, /* no argument */ - INST_INUM, /* fixed integer */ - INST_SCM, /* scheme object */ - INST_EXT, /* external offset */ - INST_TOP, /* top-level variable */ - INST_CODE, /* program code */ - INST_ADDR /* program address */ -}; - -struct scm_instruction { - enum scm_opcode opcode; /* opcode */ - enum scm_inst_type type; /* argument type */ - char *name; /* instruction name */ - SCM obj; /* instruction object */ - /* fields for VM functions */ - char *sname; /* Scheme procedure name */ - char nargs; /* the number of arguments */ - char restp; /* have a rest argument or not */ -}; - -#define SCM_INSTRUCTION_P(OBJ) SCM_SMOB_PREDICATE (scm_instruction_tag, OBJ) -#define SCM_INSTRUCTION_DATA(INST) ((struct scm_instruction *) SCM_SMOB_DATA (INST)) -#define SCM_VALIDATE_INSTRUCTION(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, INSTRUCTION_P) - -#define SCM_SYSTEM_INSTRUCTION_P(OBJ) \ - (SCM_INSTRUCTION_P (OBJ) && !SCM_INSTRUCTION_DATA(OBJ)->sname) -#define SCM_FUNCTIONAL_INSTRUCTION_P(OBJ) \ - (SCM_INSTRUCTION_P (OBJ) && SCM_INSTRUCTION_DATA(OBJ)->sname) +#define SCM_VM_MAKE_FRAME_ADDRESS(ptr) SCM_PACK (ptr) +#define SCM_VM_FRAME_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr)) -#define SCM_ADDR_TO_CODE(ADDR) SCM_PACK (ADDR) -#define SCM_CODE_TO_ADDR(CODE) ((void *) SCM_UNPACK (CODE)) -#define SCM_CODE_TO_DEBUG_ADDR(CODE) instruction_code_to_debug_addr (CODE) +#define SCM_VM_MAKE_BYTE_ADDRESS(ptr) SCM_PACK (ptr) +#define SCM_VM_BYTE_ADDRESS(addr) ((scm_byte_t *) SCM_UNPACK (addr)) - /* - * Bytecode + * VM Frame */ -struct scm_bytecode { - int size; /* the size of the bytecode */ - char nreqs; /* the number of required arguments */ - char restp; /* have a rest argument or not */ - char nvars; /* the number of local variables */ - char nexts; /* the number of external variables */ - int *exts; /* externalized arguments */ - SCM base[0]; /* base address (must be the last!) */ -}; - -#define SCM_BYTECODE_P(OBJ) SCM_SMOB_PREDICATE (scm_bytecode_tag, OBJ) -#define SCM_BYTECODE_DATA(BC) ((struct scm_bytecode *) SCM_SMOB_DATA (BC)) -#define SCM_VALIDATE_BYTECODE(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, BYTECODE_P) - -#define SCM_BYTECODE_SIZE(BC) SCM_BYTECODE_DATA (BC)->size -#define SCM_BYTECODE_NREQS(BC) SCM_BYTECODE_DATA (BC)->nreqs -#define SCM_BYTECODE_RESTP(BC) SCM_BYTECODE_DATA (BC)->restp -#define SCM_BYTECODE_NVARS(BC) SCM_BYTECODE_DATA (BC)->nvars -#define SCM_BYTECODE_NEXTS(BC) SCM_BYTECODE_DATA (BC)->nexts -#define SCM_BYTECODE_EXTS(BC) SCM_BYTECODE_DATA (BC)->exts -#define SCM_BYTECODE_BASE(BC) SCM_BYTECODE_DATA (BC)->base - -extern SCM scm_bytecode_p (SCM obj); -extern SCM scm_make_bytecode (SCM code); -extern SCM scm_bytecode_decode (SCM bytecode); - - /* - * Program - */ + | | <- fp + bp->nargs + bp->nlocs + +------------------+ + | Argument 1 | + | Argument 2 | + | Local variable 1 | + | Local varialbe 2 | <- fp + | Program | + | Dynamic link | + | Return address | <- fp - SCM_VM_FRAME_DATA_SIZE + +------------------+ + | | +*/ + +/* Frames are allocated on the stack */ +#define SCM_VM_FRAME_DATA_SIZE 3 +#define SCM_VM_FRAME_VARIABLE(fp,i) fp[i] +#define SCM_VM_FRAME_PROGRAM(fp) fp[-1] +#define SCM_VM_FRAME_DYNAMIC_LINK(fp) fp[-2] +#define SCM_VM_FRAME_RETURN_ADDRESS(fp) fp[-3] + +#define SCM_VM_FRAME_UPPER_ADDRESS(fp) \ + (fp + SCM_PROGRAM_NARGS (SCM_VM_FRAME_PROGRAM (fp)) \ + + SCM_PROGRAM_NLOCS (SCM_VM_FRAME_PROGRAM (fp))) +#define SCM_VM_FRAME_LOWER_ADDRESS(fp) \ + (fp - SCM_VM_FRAME_DATA_SIZE) -#define SCM_MAKE_PROGRAM(CODE,ENV) make_program (CODE, ENV) -#define SCM_PROGRAM_P(OBJ) SCM_SMOB_PREDICATE (scm_program_tag, OBJ) -#define SCM_PROGRAM_CODE(PROG) SCM_CELL_OBJECT_1 (PROG) -#define SCM_PROGRAM_ENV(PROG) SCM_CELL_OBJECT_2 (PROG) -#define SCM_VALIDATE_PROGRAM(POS,PROG) SCM_MAKE_VALIDATE (POS, PROG, PROGRAM_P) - -/* Abbreviations */ -#define SCM_PROGRAM_SIZE(PROG) SCM_BYTECODE_SIZE (SCM_PROGRAM_CODE (PROG)) -#define SCM_PROGRAM_NREQS(PROG) SCM_BYTECODE_NREQS (SCM_PROGRAM_CODE (PROG)) -#define SCM_PROGRAM_RESTP(PROG) SCM_BYTECODE_RESTP (SCM_PROGRAM_CODE (PROG)) -#define SCM_PROGRAM_NVARS(PROG) SCM_BYTECODE_NVARS (SCM_PROGRAM_CODE (PROG)) -#define SCM_PROGRAM_NEXTS(PROG) SCM_BYTECODE_NEXTS (SCM_PROGRAM_CODE (PROG)) -#define SCM_PROGRAM_EXTS(PROG) SCM_BYTECODE_EXTS (SCM_PROGRAM_CODE (PROG)) -#define SCM_PROGRAM_BASE(PROG) SCM_BYTECODE_BASE (SCM_PROGRAM_CODE (PROG)) - -extern SCM scm_program_p (SCM obj); -extern SCM scm_make_program (SCM bytecode, SCM env); -extern SCM scm_program_code (SCM program); -extern SCM scm_program_base (SCM program); - - /* - * VM Address + * VM Debug frame */ -#define SCM_VM_MAKE_ADDRESS(ADDR) SCM_MAKINUM ((long) (ADDR)) -#define SCM_VM_ADDRESS(OBJ) ((SCM *) SCM_INUM (OBJ)) +struct scm_vm_debug_frame { + SCM program; + SCM variables; + SCM dynamic_link; +}; - -/* - * VM External - */ +extern scm_bits_t scm_tc16_vm_debug_frame; -/* VM external maintains a set of variables outside of the stack. - This is used to implement external chain of the environment. */ +#define SCM_VM_DEBUG_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_debug_frame, x) +#define SCM_VM_DEBUG_FRAME_DATA(f) ((struct scm_vm_debug_frame *) SCM_SMOB_DATA (f)) +#define SCM_VALIDATE_VM_DEBUG_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_DEBUG_FRAME_P) -#define SCM_VM_MAKE_EXTERNAL(SIZE) scm_make_vector (SCM_MAKINUM ((SIZE) + 1), SCM_UNDEFINED) -#define SCM_VM_EXTERNAL_LINK(EXT) (SCM_VELTS (EXT)[0]) -#define SCM_VM_EXTERNAL_VARIABLE(EXT,N) (SCM_VELTS (EXT)[(N) + 1]) +#define SCM_VM_DEBUG_FRAME_PROGRAM(f) SCM_VM_DEBUG_FRAME_DATA (f)->program +#define SCM_VM_DEBUG_FRAME_VARIABLES(f) SCM_VM_DEBUG_FRAME_DATA (f)->variables +#define SCM_VM_DEBUG_FRAME_DYNAMIC_LINK(f) SCM_VM_DEBUG_FRAME_DATA (f)->dynamic_link - /* - * VM Continuation + * VM */ -#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_cont_tag, OBJ) -#define SCM_VM_CONT_VMP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT)) +#define SCM_VM_BOOT_HOOK 0 +#define SCM_VM_HALT_HOOK 1 +#define SCM_VM_NEXT_HOOK 2 +#define SCM_VM_ENTER_HOOK 3 +#define SCM_VM_APPLY_HOOK 4 +#define SCM_VM_EXIT_HOOK 5 +#define SCM_VM_RETURN_HOOK 6 +#define SCM_VM_NUM_HOOKS 7 -#define SCM_VM_CAPTURE_CONT(VMP) capture_vm_cont (VMP) -#define SCM_VM_REINSTATE_CONT(VMP,CONT) reinstate_vm_cont (VMP, CONT) +struct scm_vm { + scm_byte_t *ip; /* instruction pointer */ + SCM *sp; /* stack pointer */ + SCM *fp; /* frame pointer */ + size_t stack_size; /* stack size */ + SCM *stack_base; /* stack base address */ + SCM *stack_limit; /* stack limit address */ + SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */ + SCM options; /* options */ + unsigned long cons; /* cons count */ + unsigned long time; /* time spent */ + unsigned long clock; /* bogos clock */ +}; - -/* - * VM Frame - */ +#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) -/* VM frame is allocated in the stack */ -/* NOTE: Modify make_vm_frame and VM_NEW_FRAME too! */ -#define SCM_VM_FRAME_DATA_SIZE 6 -#define SCM_VM_FRAME_VARIABLE(FP,N) (FP[N]) -#define SCM_VM_FRAME_SIZE(FP) (FP[-1]) -#define SCM_VM_FRAME_PROGRAM(FP) (FP[-2]) -#define SCM_VM_FRAME_DYNAMIC_LINK(FP) (FP[-3]) -#define SCM_VM_FRAME_EXTERNAL_LINK(FP) (FP[-4]) -#define SCM_VM_FRAME_STACK_POINTER(FP) (FP[-5]) -#define SCM_VM_FRAME_RETURN_ADDRESS(FP) (FP[-6]) - - -/* - * VM - */ +extern SCM scm_make_vm (void); +extern SCM scm_vm_apply (SCM vm, SCM program, SCM args); +extern SCM scm_vm_option_ref (SCM vm, SCM key); +extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); -/* Modify make_vm, mark_vm, and SYNC, too! */ -struct scm_vm { - SCM ac; /* Accumulator */ - SCM *pc; /* Program counter */ - SCM *sp; /* Stack pointer */ - SCM *fp; /* Frame pointer */ - int stack_size; - SCM *stack_base; - SCM *stack_limit; - SCM options; - SCM boot_hook, halt_hook, next_hook; - SCM call_hook, apply_hook, return_hook; -}; +extern SCM scm_vm_current_frame (SCM vm); -#define SCM_VM_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_tag, OBJ) -#define SCM_VM_DATA(VM) ((struct scm_vm *) SCM_SMOB_DATA (VM)) -#define SCM_VALIDATE_VM(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_P) +extern void scm_init_vm (void); -/* Engine types */ -#define SCM_VM_REGULAR_ENGINE 0 /* Fail safe and fast enough */ -#define SCM_VM_DEBUG_ENGINE 1 /* Functional but very slow */ +#endif /* _VM_H_ */ -#endif /* not VM_H */ +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/vm_engine.c b/src/vm_engine.c index ab68ce028..bff9825a7 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -39,80 +39,130 @@ * 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 two times! */ +/* This file is included in vm.c twice */ #include "vm_engine.h" -/* VM names */ -#undef VM_NAME -#if VM_ENGINE == SCM_VM_REGULAR_ENGINE -#define VM_NAME scm_regular_vm -#else -#if VM_ENGINE == SCM_VM_DEBUG_ENGINE -#define VM_NAME scm_debug_vm -#endif -#endif - static SCM -VM_NAME (SCM vm, SCM program) +vm_engine (SCM vm, SCM program, SCM args) #define FUNC_NAME "vm-engine" { - /* Copies of VM registers */ - SCM ac = SCM_PACK (0); /* accumulator */ - SCM *pc = NULL; /* program counter */ - SCM *sp = NULL; /* stack pointer */ - SCM *fp = NULL; /* frame pointer */ + /* VM registers */ + register scm_byte_t *ip IP_REG; /* instruction pointer */ + register SCM *sp SP_REG; /* stack pointer */ + register SCM *fp FP_REG; /* frame pointer */ /* Cache variables */ - struct scm_vm *vmp = NULL; /* the VM data pointer */ - SCM ext = SCM_BOOL_F; /* the current external frame */ - SCM *stack_base = NULL; /* stack base address */ - SCM *stack_limit = NULL; /* stack limit address */ + struct scm_vm *vmp = SCM_VM_DATA (vm);/* VM data pointer */ + struct scm_program *bp = NULL; /* program base pointer */ + SCM external; /* external environment */ + SCM *objects = NULL; /* constant objects */ + SCM *stack_base = vmp->stack_base; /* stack base address */ + SCM *stack_limit = vmp->stack_limit; /* stack limit address */ /* Internal variables */ - int nargs = 0; /* the number of arguments */ - SCM dynwinds = SCM_EOL; -#if VM_USE_HOOK + int nargs = 0; + long run_time = scm_c_get_internal_run_time (); + // SCM dynwinds = SCM_EOL; + SCM err_msg; + SCM err_args; +#if VM_USE_HOOKS SCM hook_args = SCM_LIST1 (vm); #endif +#ifdef HAVE_LABELS_AS_VALUES /* Jump talbe */ static void *jump_table[] = { -#define VM_INSTRUCTION_TO_LABEL +#define VM_INSTRUCTION_TO_LABEL 1 #include "vm_expand.h" #include "vm_system.i" #include "vm_scheme.i" #include "vm_number.i" +#include "vm_loader.i" #undef VM_INSTRUCTION_TO_LABEL }; +#endif - /* Initialize the VM */ - vmp = SCM_VM_DATA (vm); - vmp->pc = SCM_PROGRAM_BASE (program); - vmp->sp = vmp->stack_limit; - LOAD (); + /* Bootcode */ + scm_byte_t code[3] = {scm_op_call, 0, scm_op_halt}; + SCM bootcode = scm_c_make_program (code, 3, SCM_BOOL_T); + code[1] = scm_ilength (args); - /* top frame */ - VM_NEW_FRAME (fp, program, SCM_BOOL_F, - SCM_VM_MAKE_ADDRESS (0), - SCM_VM_MAKE_ADDRESS (0)); + /* Initial frame */ + bp = SCM_PROGRAM_DATA (bootcode); + CACHE (); + NEW_FRAME (); + + /* Initial arguments */ + for (; !SCM_NULLP (args); args = SCM_CDR (args)) + PUSH (SCM_CAR (args)); + PUSH (program); /* Let's go! */ - VM_BOOT_HOOK (); + BOOT_HOOK (); #ifndef HAVE_LABELS_AS_VALUES - vm_start: switch (*pc++) { + vm_start: + switch (*ip++) { #endif #include "vm_expand.h" #include "vm_system.c" #include "vm_scheme.c" #include "vm_number.c" +#include "vm_loader.c" #ifndef HAVE_LABELS_AS_VALUES } #endif + /* Errors */ + { + vm_error_unbound: + err_msg = scm_makfrom0str ("Unbound variable: ~A"); + goto vm_error; + + vm_error_wrong_num_args: + err_msg = scm_makfrom0str ("Wrong number of arguments"); + err_args = SCM_EOL; + goto vm_error; + + vm_error_wrong_type_apply: + err_msg = scm_makfrom0str ("Wrong type to apply: ~S"); + err_args = SCM_LIST1 (program); + goto vm_error; + +#if VM_CHECK_IP + vm_error_invalid_address: + err_msg = scm_makfrom0str ("Invalid program address"); + err_args = SCM_EOL; + goto vm_error; +#endif + + vm_error_stack_overflow: + err_msg = scm_makfrom0str ("Stack overflow"); + err_args = SCM_EOL; + goto vm_error; + + vm_error_stack_underflow: + err_msg = scm_makfrom0str ("Stack underflow"); + err_args = SCM_EOL; + goto vm_error; + + vm_error: + SYNC_ALL (); + scm_ithrow (sym_vm_error, + SCM_LIST4 (sym_vm_engine, err_msg, err_args, + scm_vm_current_frame (vm)), + 1); + } + abort (); /* never reached */ } #undef FUNC_NAME + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/vm_engine.h b/src/vm_engine.h index 151e5969c..6d4f41391 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -45,80 +45,72 @@ * VM Options */ -#undef VM_USE_BOOT_HOOK -#undef VM_USE_HALT_HOOK -#undef VM_USE_NEXT_HOOK -#undef VM_USE_CALL_HOOK -#undef VM_USE_APPLY_HOOK -#undef VM_USE_RETURN_HOOK -#undef VM_INIT_LOCAL_VARIABLES -#undef VM_CHECK_LINK -#undef VM_CHECK_BINDING -#undef VM_CHECK_PROGRAM_COUNTER - -#if VM_ENGINE == SCM_VM_REGULAR_ENGINE -#define VM_USE_BOOT_HOOK 0 -#define VM_USE_HALT_HOOK 0 -#define VM_USE_NEXT_HOOK 0 -#define VM_USE_CALL_HOOK 0 -#define VM_USE_APPLY_HOOK 0 -#define VM_USE_RETURN_HOOK 0 -#define VM_INIT_LOCAL_VARIABLES 0 -#define VM_CHECK_LINK 0 -#define VM_CHECK_BINDING 1 -#define VM_CHECK_PROGRAM_COUNTER 0 -#else -#if VM_ENGINE == SCM_VM_DEBUG_ENGINE -#define VM_USE_BOOT_HOOK 1 -#define VM_USE_HALT_HOOK 1 -#define VM_USE_NEXT_HOOK 1 -#define VM_USE_CALL_HOOK 1 -#define VM_USE_APPLY_HOOK 1 -#define VM_USE_RETURN_HOOK 1 -#define VM_INIT_LOCAL_VARIABLES 1 -#define VM_CHECK_LINK 1 -#define VM_CHECK_BINDING 1 -#define VM_CHECK_PROGRAM_COUNTER 1 -#endif -#endif +#define VM_OPTION(regular,debug) debug -#undef VM_USE_HOOK -#if VM_USE_BOOT_HOOK || VM_USE_HALT_HOOK || VM_USE_NEXT_HOOK \ - || VM_USE_CALL_HOOK || VM_USE_APPLY_HOOK || VM_USE_RETURN_HOOK -#define VM_USE_HOOK 1 -#else -#define VM_USE_HOOK 0 -#endif +#define VM_USE_HOOKS VM_OPTION (0, 1) /* Various hooks */ +#define VM_USE_CLOCK VM_OPTION (0, 1) /* Bogos clock */ +#define VM_CHECK_IP VM_OPTION (0, 0) /* Check IP */ /* - * Type checking + * Registers */ -#undef VM_ASSERT_LINK -#if VM_CHECK_LINK -#define VM_ASSERT_LINK(OBJ) \ - if (SCM_FALSEP (OBJ)) \ - SCM_MISC_ERROR ("VM broken link", SCM_EOL) -#else -#define VM_ASSERT_LINK(OBJ) -#endif - - -/* - * Top-level variable - */ +/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ] -#define VM_VARIABLE_REF(VAR) SCM_CDDR (VAR) -#define VM_VARIABLE_SET(VAR,VAL) SCM_SETCDR (SCM_CDR (VAR), VAL) + 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. +*/ -#undef VM_ASSERT_BOUND -#if VM_CHECK_BINDING -#define VM_ASSERT_BOUND(VAR) \ - if (SCM_UNBNDP (VM_VARIABLE_REF (VAR))) \ - SCM_MISC_ERROR ("Unbound variable: ~S", SCM_LIST1 (SCM_CADR (VAR))) +#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 VM_ASSERT_BOUND(CELL) +#define IP_REG asm("$9") +#define SP_REG asm("$10") +#define FP_REG asm("$11") +#endif +#endif +#ifdef __i386__ +#define IP_REG asm("%esi") +#define SP_REG asm("%edi") +#define FP_REG +#endif +#if defined(PPC) || defined(_POWER) || defined(_IBMR2) +#define IP_REG asm("26") +#define SP_REG asm("27") +#define FP_REG asm("28") +#endif +#ifdef __hppa__ +#define IP_REG asm("%r18") +#define SP_REG asm("%r17") +#define FP_REG asm("%r16") +#endif +#ifdef __mc68000__ +#define IP_REG asm("a5") +#define SP_REG asm("a4") +#define FP_REG +#endif +#ifdef __arm__ +#define IP_REG asm("r9") +#define SP_REG asm("r8") +#define FP_REG asm("r7") +#endif #endif @@ -126,239 +118,221 @@ * Hooks */ -#undef VM_BOOT_HOOK -#if VM_USE_BOOT_HOOK -#define VM_BOOT_HOOK() SYNC (); scm_c_run_hook (vmp->boot_hook, hook_args) -#else -#define VM_BOOT_HOOK() -#endif - -#undef VM_HALT_HOOK -#if VM_USE_HALT_HOOK -#define VM_HALT_HOOK() SYNC (); scm_c_run_hook (vmp->halt_hook, hook_args) -#else -#define VM_HALT_HOOK() -#endif - -#undef VM_NEXT_HOOK -#if VM_USE_NEXT_HOOK -#define VM_NEXT_HOOK() SYNC (); scm_c_run_hook (vmp->next_hook, hook_args) -#else -#define VM_NEXT_HOOK() -#endif - -#undef VM_CALL_HOOK -#if VM_USE_CALL_HOOK -#define VM_CALL_HOOK() SYNC (); scm_c_run_hook (vmp->call_hook, hook_args) -#else -#define VM_CALL_HOOK() -#endif - -#undef VM_APPLY_HOOK -#if VM_USE_APPLY_HOOK -#define VM_APPLY_HOOK() SYNC (); scm_c_run_hook (vmp->apply_hook, hook_args) +#undef RUN_HOOK +#if VM_USE_HOOKS +#define RUN_HOOK(h) \ +{ \ + if (!SCM_FALSEP (h)) \ + { \ + SYNC (); \ + scm_c_run_hook (h, hook_args); \ + } \ +} #else -#define VM_APPLY_HOOK() +#define RUN_HOOK(h) #endif -#undef VM_RETURN_HOOK -#if VM_USE_RETURN_HOOK -#define VM_RETURN_HOOK() SYNC (); scm_c_run_hook (vmp->return_hook, hook_args) -#else -#define VM_RETURN_HOOK() -#endif +#define BOOT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_BOOT_HOOK]) +#define HALT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_HALT_HOOK]) +#define NEXT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_NEXT_HOOK]) +#define ENTER_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_ENTER_HOOK]) +#define APPLY_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_APPLY_HOOK]) +#define EXIT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_EXIT_HOOK]) +#define RETURN_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_RETURN_HOOK]) /* * Basic operations */ -#define LOAD() \ +#define CACHE() \ { \ - ac = vmp->ac; \ - pc = vmp->pc; \ + ip = vmp->ip; \ sp = vmp->sp; \ fp = vmp->fp; \ - stack_base = vmp->stack_base; \ - stack_limit = vmp->stack_limit; \ } #define SYNC() \ { \ - vmp->ac = ac; \ - vmp->pc = pc; \ + vmp->ip = ip; \ vmp->sp = sp; \ vmp->fp = fp; \ } -#define FETCH() *pc++ +#define SYNC_TIME() \ +{ \ + long cur_time = scm_c_get_internal_run_time (); \ + vmp->time += cur_time - run_time; \ + run_time = cur_time; \ +} -#define CONS(X,Y,Z) \ +#define SYNC_ALL() \ { \ - SCM cell; \ SYNC (); \ - SCM_NEWCELL (cell); \ - SCM_SET_CELL_OBJECT_0 (cell, Y); \ - SCM_SET_CELL_OBJECT_1 (cell, Z); \ - X = cell; \ + SYNC_TIME (); \ } -#define VM_SETUP_ARGS1() SCM a1 = ac; -#define VM_SETUP_ARGS2() SCM a1, a2; a2 = ac; POP (a1); -#define VM_SETUP_ARGS3() SCM a1, a2, a3; a3 = ac; POP (a2); POP (a1); -#define VM_SETUP_ARGSN() nargs = SCM_INUM (FETCH ()); - /* * Stack operation */ -#define PUSH(X) \ -{ \ +#define CHECK_OVERFLOW() \ if (sp < stack_base) \ - SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \ - *sp-- = (X); \ -} + goto vm_error_stack_overflow + +#define CHECK_UNDERFLOW() \ + if (sp > stack_limit) \ + goto vm_error_stack_underflow -#define POP(X) \ +#define PUSH(x) do { CHECK_OVERFLOW (); *--sp = x; } while (0) +#define DROP() do { CHECK_UNDERFLOW (); sp++; } while (0) +#define POP(x) do { x = *sp; DROP (); } while (0) + +#define CONS(x,y,z) \ { \ - if (sp == stack_limit) \ - SCM_MISC_ERROR ("FIXME: Stack underflow", SCM_EOL); \ - (X) = *++sp; \ + SCM cell; \ + SYNC () \ + SCM_NEWCELL (cell); \ + SCM_SET_CELL_OBJECT_0 (cell, y); \ + SCM_SET_CELL_OBJECT_1 (cell, z); \ + x = cell; \ } -#define POP_LIST(N,L) \ -{ \ - while (N-- > 0) \ +#define POP_LIST(n) \ +do { \ + int i; \ + SCM l = SCM_EOL; \ + for (i = 0; i < n; i++) \ + CONS (l, sp[i], l); \ + sp += n - 1; \ + *sp = l; \ +} while (0) + +#define POP_LIST_MARK() \ +do { \ + SCM x; \ + SCM l = SCM_EOL; \ + POP (x); \ + while (!SCM_UNBNDP (x)) \ { \ - SCM obj; \ - POP (obj); \ - CONS (L, obj, L); \ + CONS (l, x, l); \ + POP (x); \ } \ -} + PUSH (l); \ +} while (0) /* - * Frame allocation + * Instruction operation */ -/* nargs = the number of arguments */ -#define VM_FRAME_INIT_ARGS(PROG,NREQS,RESTP) \ -{ \ - if (RESTP) \ - /* have a rest argument */ \ - { \ - SCM list; \ - if (nargs < NREQS) \ - scm_wrong_num_args (PROG); \ - \ - /* Construct the rest argument list */ \ - nargs -= NREQS; /* the number of rest arguments */ \ - list = SCM_EOL; /* list of the rest arguments */ \ - POP_LIST (nargs, list); \ - PUSH (list); \ - } \ - else \ - /* not have a rest argument */ \ - { \ - if (nargs != NREQS) \ - scm_wrong_num_args (PROG); \ - } \ -} +#define FETCH() (*ip++) +#define FETCH2() (((int) FETCH () << 8) + (int) FETCH ()) -#undef VM_FRAME_INIT_LOCAL_VARIABLES -#if VM_INIT_LOCAL_VARIABLES -/* This is necessary when creating frame objects for debugging */ -#define VM_FRAME_INIT_LOCAL_VARIABLES(FP,NVARS) \ -{ \ - int i; \ - for (i = 0; i < NVARS; i++) \ - SCM_VM_FRAME_VARIABLE (FP, i) = SCM_UNDEFINED; \ -} +#define FETCH_LENGTH(len) do { ip = vm_fetch_length (ip, &len); } while (0) + +#undef CLOCK +#if VM_USE_CLOCK +#define CLOCK(n) vmp->clock += n #else -#define VM_FRAME_INIT_LOCAL_VARIABLES(FP,NVARS) +#define CLOCK(n) #endif -#define VM_FRAME_INIT_EXTERNAL_VARIABLES(FP,PROG) \ -{ \ - int *exts = SCM_PROGRAM_EXTS (PROG); \ - if (exts) \ - { \ - /* Export variables */ \ - int n = exts[0]; \ - while (n-- > 0) \ - SCM_VM_EXTERNAL_VARIABLE (ext, n) \ - = SCM_VM_FRAME_VARIABLE (FP, exts[n + 1]); \ - } \ +#undef NEXT_CHECK +#if VM_CHECK_IP +#define NEXT_CHECK() \ +{ \ + scm_byte_t *base = bp->base; \ + if (ip < base || ip >= base + bp->size) \ + goto vm_error_invalid_address; \ } +#else +#define NEXT_CHECK() +#endif -#define VM_NEW_FRAME(FP,PROG,DL,SP,RA) \ -{ \ - int nvars = SCM_PROGRAM_NVARS (PROG); /* the number of local vars */ \ - int nreqs = SCM_PROGRAM_NREQS (PROG); /* the number of required args */ \ - int restp = SCM_PROGRAM_RESTP (PROG); /* have a rest argument or not */ \ - int nexts = SCM_PROGRAM_NEXTS (PROG); /* the number of external vars */ \ - \ - VM_FRAME_INIT_ARGS (PROG, nreqs, restp); \ - \ - /* Allocate the new frame */ \ - if (sp - nvars - SCM_VM_FRAME_DATA_SIZE < stack_base - 1) \ - SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \ - sp -= nvars + SCM_VM_FRAME_DATA_SIZE; \ - FP = sp + SCM_VM_FRAME_DATA_SIZE + 1; \ - \ - /* Setup the new external frame */ \ - if (!SCM_FALSEP (SCM_PROGRAM_ENV (PROG))) \ - ext = SCM_PROGRAM_ENV (PROG); /* Use program's environment */ \ - if (nexts) \ - { \ - SCM new = SCM_VM_MAKE_EXTERNAL (nexts); /* new external */ \ - SCM_VM_EXTERNAL_LINK (new) = ext; \ - ext = new; \ - } \ - \ - /* Setup the new frame */ \ - SCM_VM_FRAME_SIZE (FP) = SCM_MAKINUM (nvars); \ - SCM_VM_FRAME_PROGRAM (FP) = PROG; \ - SCM_VM_FRAME_DYNAMIC_LINK (FP) = DL; \ - SCM_VM_FRAME_EXTERNAL_LINK (FP) = ext; \ - SCM_VM_FRAME_STACK_POINTER (FP) = SP; \ - SCM_VM_FRAME_RETURN_ADDRESS (FP) = RA; \ - VM_FRAME_INIT_LOCAL_VARIABLES (FP, nvars); \ - VM_FRAME_INIT_EXTERNAL_VARIABLES (FP, PROG); \ +#undef NEXT_JUMP +#ifdef HAVE_LABELS_AS_VALUES +#define NEXT_JUMP() goto *jump_table[FETCH ()] +#else +#define NEXT_JUMP() goto vm_start +#endif + +#define NEXT \ +{ \ + CLOCK (1); \ + NEXT_CHECK (); \ + NEXT_HOOK (); \ + NEXT_JUMP (); \ } /* - * Goto next + * Function support */ -#undef VM_PROGRAM_COUNTER_CHECK -#if VM_CHECK_PROGRAM_COUNTER -#define VM_PROGRAM_COUNTER_CHECK() \ -{ \ - SCM prog = SCM_VM_FRAME_PROGRAM (fp); \ - if (pc < SCM_PROGRAM_BASE (prog) \ - || pc >= (SCM_PROGRAM_BASE (prog) + SCM_PROGRAM_SIZE (prog))) \ - SCM_MISC_ERROR ("VM accessed invalid program address", SCM_EOL); \ -} -#else -#define VM_PROGRAM_COUNTER_CHECK() -#endif +#define ARGS1(a1) SCM a1 = sp[0]; +#define ARGS2(a1,a2) SCM a1 = sp[1], a2 = sp[0]; sp++; +#define ARGS3(a1,a2,a3) SCM a1 = sp[2], a2 = sp[1], a3 = sp[0]; sp += 2; +#define ARGSN(an) int an = FETCH (); -#undef VM_GOTO_NEXT -#if HAVE_LABELS_AS_VALUES -#define VM_GOTO_NEXT() goto *jump_table[SCM_UNPACK (FETCH ())] -#else /* not HAVE_LABELS_AS_VALUES */ -#define VM_GOTO_NEXT() goto vm_start -#endif +#define RETURN(x) { *sp = x; NEXT; } -#define NEXT \ + +/* + * Frame allocation + */ + +#define NEW_FRAME() \ { \ - VM_PROGRAM_COUNTER_CHECK (); \ - VM_NEXT_HOOK (); \ - VM_GOTO_NEXT (); \ + SCM ra = SCM_VM_MAKE_FRAME_ADDRESS (ip); \ + SCM dl = SCM_VM_MAKE_BYTE_ADDRESS (fp); \ + ip = bp->base; \ + fp = sp - bp->nlocs; \ + sp = SCM_VM_FRAME_LOWER_ADDRESS (fp); \ + CHECK_OVERFLOW (); \ + SCM_VM_FRAME_PROGRAM (fp) = program; \ + SCM_VM_FRAME_DYNAMIC_LINK (fp) = dl; \ + SCM_VM_FRAME_RETURN_ADDRESS (fp) = ra; \ +} + +#define FREE_FRAME() \ +{ \ + sp = fp + bp->nargs + bp->nlocs; \ + ip = SCM_VM_BYTE_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (fp)); \ + fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp)); \ } -/* Just an abbreviation */ -#define RETURN(X) { ac = (X); NEXT; } +#define INIT_ARGS() \ +{ \ + if (bp->nrest) \ + { \ + int n = nargs - bp->nargs - 1; \ + if (n < 0) \ + goto vm_error_wrong_num_args; \ + POP_LIST (n); \ + } \ + else \ + { \ + if (nargs != bp->nargs) \ + goto vm_error_wrong_num_args; \ + } \ +} + +#define INIT_VARIABLES() \ +{ \ + int i; \ + for (i = 0; i < bp->nlocs; i++) \ + SCM_VM_FRAME_VARIABLE (fp, i) = SCM_UNDEFINED; \ +} + +#define CACHE_PROGRAM() \ + bp = SCM_PROGRAM_DATA (program); \ + objects = SCM_VELTS (bp->objs); \ + external = bp->external; + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/vm_expand.h b/src/vm_expand.h index 1eeea817e..590759399 100644 --- a/src/vm_expand.h +++ b/src/vm_expand.h @@ -42,52 +42,58 @@ #include "config.h" #ifndef VM_LABEL -#define VM_LABEL(TAG) l_##TAG## -#define VM_OPCODE(TAG) op_##TAG## +#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) +#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 +#define VM_TAG(tag) case VM_OPCODE(tag): +#define VM_ADDR(tag) NULL #endif /* not HAVE_LABELS_AS_VALUES */ #endif /* VM_LABEL */ -#undef SCM_DEFINE_INSTRUCTION -#undef SCM_DEFINE_VM_FUNCTION +#undef VM_DEFINE_INSTRUCTION +#undef VM_DEFINE_FUNCTION #ifdef VM_INSTRUCTION_TO_TABLE /* * These will go to scm_instruction_table in vm.c */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ - {VM_OPCODE(TAG), TYPE, NAME, SCM_PACK (0), NULL, 0, 0}, -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ - {VM_OPCODE(TAG), INST_NONE, NAME, SCM_PACK (0), SNAME, NARGS, RESTP}, +#define VM_DEFINE_INSTRUCTION(tag,name,len) \ + {VM_OPCODE (tag), name, len}, +#define VM_DEFINE_FUNCTION(tag,name,nargs) \ + {VM_OPCODE (tag), name, 0}, #else #ifdef VM_INSTRUCTION_TO_LABEL /* * These will go to jump_table in vm_engine.c */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_ADDR(TAG), -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_ADDR(TAG), +#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_ADDR (tag), +#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag), #else #ifdef VM_INSTRUCTION_TO_OPCODE /* * These will go to scm_opcode in vm.h */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_OPCODE(TAG), -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_OPCODE(TAG), +#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_OPCODE (tag), +#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag), #else /* Otherwise */ /* * These are directly included in vm_engine.c */ -#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_TAG(TAG) -#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_TAG(TAG) +#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_TAG (tag) +#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag) #endif /* VM_INSTRUCTION_TO_OPCODE */ #endif /* VM_INSTRUCTION_TO_LABEL */ #endif /* VM_INSTRUCTION_TO_TABLE */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/vm_loader.c b/src/vm_loader.c new file mode 100644 index 000000000..1dd3eb453 --- /dev/null +++ b/src/vm_loader.c @@ -0,0 +1,133 @@ +/* Copyright (C) 2000 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* This file is included in vm_engine.c */ + +VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1) +{ + size_t len; + FETCH_LENGTH (len); + SCM_MISC_ERROR ("Not implemented yet", SCM_EOL); + ip += len; + NEXT; +} + +VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1) +{ + size_t len; + FETCH_LENGTH (len); + PUSH (scm_mem2symbol (ip, len)); + ip += len; + NEXT; +} + +VM_DEFINE_INSTRUCTION (load_string, "load-string", -1) +{ + size_t len; + FETCH_LENGTH (len); + PUSH (scm_makfromstr (ip, len, 0)); + ip += len; + NEXT; +} + +VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1) +{ + SCM sym; + size_t len; + FETCH_LENGTH (len); + sym = scm_mem2symbol (ip, len); + PUSH (scm_make_keyword_from_dash_symbol (sym)); + ip += len; + NEXT; +} + +VM_DEFINE_INSTRUCTION (load_module, "load-module", -1) +{ + size_t len; + FETCH_LENGTH (len); + PUSH (scm_c_lookup_env (scm_mem2symbol (ip, len))); + ip += len; + NEXT; +} + +VM_DEFINE_INSTRUCTION (load_program, "load-program", -1) +{ + size_t len; + SCM prog, x; + + FETCH_LENGTH (len); + prog = scm_c_make_program (ip, len, program); + + x = sp[0]; + if (SCM_INUMP (x)) + { + int i = SCM_INUM (x); + SCM_PROGRAM_NARGS (prog) = i >> 5; /* 6-5 bits */ + SCM_PROGRAM_NREST (prog) = (i >> 4) & 1; /* 4 bit */ + SCM_PROGRAM_NLOCS (prog) = i & 15; /* 3-0 bits */ + } + else + { + SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[3]); + SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]); + SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[1]); + if (SCM_VECTORP (x)) + SCM_PROGRAM_OBJS (prog) = x; + sp += 3; + } + + ip += len; + *sp = prog; + NEXT; +} + +VM_DEFINE_INSTRUCTION (link, "link", 0) +{ + sp[1] = scm_c_env_vcell (sp[1], sp[0], 1); + DROP (); + NEXT; +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/vm_number.c b/src/vm_number.c index cc7b63ad0..adc16e060 100644 --- a/src/vm_number.c +++ b/src/vm_number.c @@ -41,158 +41,128 @@ /* This file is included in vm_engine.c */ -#define FUNC2(CFUNC,SFUNC) \ -{ \ - VM_SETUP_ARGS2 (); \ - if (SCM_INUMP (a1) && SCM_INUMP (a2)) \ - { \ - int n = SCM_INUM (a1) CFUNC SCM_INUM (a2); \ - if (SCM_FIXABLE (n)) \ - RETURN (SCM_MAKINUM (n)); \ - } \ - RETURN (SFUNC (a1, a2)); \ + +/* + * Predicates + */ + +#undef PRED +#define PRED(ctest,stest) \ +{ \ + ARGS1 (a1); \ + if (SCM_INUMP (a1)) \ + RETURN (SCM_BOOL (ctest)); \ + RETURN (stest (a1)); \ } -#define REL2(CREL,SREL) \ +VM_DEFINE_FUNCTION (zero, "zero?", 1) +{ + PRED (SCM_INUM (a1) == 0, scm_zero_p); +} + + +/* + * Relational tests + */ + +#undef REL +#define REL(crel,srel) \ { \ - VM_SETUP_ARGS2 (); \ + ARGS2 (a1, a2); \ if (SCM_INUMP (a1) && SCM_INUMP (a2)) \ - RETURN (SCM_BOOL (SCM_INUM (a1) CREL SCM_INUM (a2))); \ - RETURN (SREL (a1, a2)); \ + RETURN (SCM_BOOL (SCM_INUM (a1) crel SCM_INUM (a2))); \ + RETURN (srel (a1, a2)); \ } -SCM_DEFINE_VM_FUNCTION (zero_p, "zero?", "zero?", 1, 0) +VM_DEFINE_FUNCTION (ee, "ee?", 2) { - VM_SETUP_ARGS1 (); - if (SCM_INUMP (a1)) - RETURN (SCM_BOOL (SCM_EQ_P (a1, SCM_INUM0))); - RETURN (scm_zero_p (a1)); + REL (==, scm_num_eq_p); } -SCM_DEFINE_VM_FUNCTION (inc, "1+", "inc", 1, 0) +VM_DEFINE_FUNCTION (lt, "lt?", 2) { - VM_SETUP_ARGS1 (); - if (SCM_INUMP (a1)) - { - int n = SCM_INUM (a1) + 1; - if (SCM_FIXABLE (n)) - RETURN (SCM_MAKINUM (n)); - } - RETURN (scm_sum (a1, SCM_MAKINUM (1))); + REL (<, scm_less_p); } -SCM_DEFINE_VM_FUNCTION (dec, "1-", "dec", 1, 0) +VM_DEFINE_FUNCTION (le, "le?", 2) { - VM_SETUP_ARGS1 (); - if (SCM_INUMP (a1)) - { - int n = SCM_INUM (a1) - 1; - if (SCM_FIXABLE (n)) - RETURN (SCM_MAKINUM (n)); - } - RETURN (scm_difference (a1, SCM_MAKINUM (1))); + REL (<=, scm_leq_p); } -SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1) +VM_DEFINE_FUNCTION (gt, "gt?", 2) { - VM_SETUP_ARGSN (); - ac = SCM_MAKINUM (0); - while (nargs-- > 0) - { - SCM x; - POP (x); - if (SCM_INUMP (ac) && SCM_INUMP (x)) - { - int n = SCM_INUM (ac) + SCM_INUM (x); - if (SCM_FIXABLE (n)) - { - ac = SCM_MAKINUM (n); - continue; - } - } - ac = scm_sum (ac, x); - } - NEXT; -} - -SCM_DEFINE_VM_FUNCTION (add2, "+", "add2", 2, 0) -{ - FUNC2 (+, scm_sum); + REL (>, scm_gr_p); } -SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1) +VM_DEFINE_FUNCTION (ge, "ge?", 2) { - SCM x; - VM_SETUP_ARGSN (); - ac = SCM_MAKINUM (0); - while (nargs-- > 1) - { - POP (x); - if (SCM_INUMP (ac) && SCM_INUMP (x)) - { - int n = SCM_INUM (ac) + SCM_INUM (x); - if (SCM_FIXABLE (n)) - { - ac = SCM_MAKINUM (n); - continue; - } - } - ac = scm_difference (ac, x); - } - POP (x); - if (SCM_INUMP (ac) && SCM_INUMP (x)) - { - int n = SCM_INUM (x) - SCM_INUM (ac); - if (SCM_FIXABLE (n)) - RETURN (SCM_MAKINUM (n)); - } - RETURN (scm_difference (x, ac)); -} - -SCM_DEFINE_VM_FUNCTION (sub2, "-", "sub2", 2, 0) -{ - FUNC2 (-, scm_difference); + REL (>=, scm_geq_p); } -SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0) -{ - VM_SETUP_ARGS1 (); - if (SCM_INUMP (a1)) - { - int n = - SCM_INUM (a1); - if (SCM_FIXABLE (n)) - RETURN (SCM_MAKINUM (n)); - } - RETURN (scm_difference (a1, SCM_UNDEFINED)); + +/* + * Functions + */ + +#undef FUNC1 +#define FUNC1(CEXP,SEXP) \ +{ \ + ARGS1 (a1); \ + if (SCM_INUMP (a1)) \ + { \ + int n = CEXP; \ + if (SCM_FIXABLE (n)) \ + RETURN (SCM_MAKINUM (n)); \ + } \ + RETURN (SEXP); \ +} + +#undef FUNC2 +#define FUNC2(CFUNC,SFUNC) \ +{ \ + ARGS2 (a1, a2); \ + if (SCM_INUMP (a1) && SCM_INUMP (a2)) \ + { \ + int n = SCM_INUM (a1) CFUNC SCM_INUM (a2); \ + if (SCM_FIXABLE (n)) \ + RETURN (SCM_MAKINUM (n)); \ + } \ + RETURN (SFUNC (a1, a2)); \ } -SCM_DEFINE_VM_FUNCTION (remainder, "remainder", "remainder", 2, 0) +VM_DEFINE_FUNCTION (neg, "neg", 1) { - VM_SETUP_ARGS2 (); - RETURN (scm_remainder (a1, a2)); + FUNC1 (- SCM_INUM (a1), scm_difference (a1, SCM_UNDEFINED)); } -SCM_DEFINE_VM_FUNCTION (lt2, "<", "lt2", 2, 0) +VM_DEFINE_FUNCTION (inc, "inc", 1) { - REL2 (<, scm_less_p); + FUNC1 (SCM_INUM (a1) + 1, scm_sum (a1, SCM_MAKINUM (1))); } -SCM_DEFINE_VM_FUNCTION (gt2, ">", "gt2", 2, 0) +VM_DEFINE_FUNCTION (dec, "dec", 1) { - REL2 (>, scm_gr_p); + FUNC1 (SCM_INUM (a1) - 1, scm_difference (a1, SCM_MAKINUM (1))); } -SCM_DEFINE_VM_FUNCTION (le2, "<=", "le2", 2, 0) +VM_DEFINE_FUNCTION (add, "add", 2) { - REL2 (<=, scm_leq_p); + FUNC2 (+, scm_sum); } -SCM_DEFINE_VM_FUNCTION (ge2, ">=", "ge2", 2, 0) +VM_DEFINE_FUNCTION (sub, "sub", 2) { - REL2 (>=, scm_geq_p); + FUNC2 (-, scm_difference); } -SCM_DEFINE_VM_FUNCTION (num_eq2, "=", "num-eq2", 2, 0) +VM_DEFINE_FUNCTION (remainder, "remainder", 2) { - REL2 (==, scm_num_eq_p); + ARGS2 (a1, a2); + RETURN (scm_remainder (a1, a2)); } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/vm_scheme.c b/src/vm_scheme.c index 3b3c6e5ab..99e9e3093 100644 --- a/src/vm_scheme.c +++ b/src/vm_scheme.c @@ -41,73 +41,106 @@ /* This file is included in vm_engine.c */ -SCM_DEFINE_VM_FUNCTION (null_p, "null?", "null?", 1, 0) +VM_DEFINE_FUNCTION (not, "not", 1) { - VM_SETUP_ARGS1 (); + ARGS1 (a1); + RETURN (SCM_BOOL (SCM_FALSEP (a1))); +} + +VM_DEFINE_FUNCTION (not_not, "not-not", 1) +{ + ARGS1 (a1); + RETURN (SCM_BOOL (!SCM_FALSEP (a1))); +} + +VM_DEFINE_FUNCTION (eq, "eq?", 2) +{ + ARGS2 (a1, a2); + RETURN (SCM_BOOL (SCM_EQ_P (a1, a2))); +} + +VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2) +{ + ARGS2 (a1, a2); + RETURN (SCM_BOOL (!SCM_EQ_P (a1, a2))); +} + +VM_DEFINE_FUNCTION (nullp, "null?", 1) +{ + ARGS1 (a1); RETURN (SCM_BOOL (SCM_NULLP (a1))); } -SCM_DEFINE_VM_FUNCTION (cons, "cons", "cons", 2, 0) +VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1) { - VM_SETUP_ARGS2 (); - CONS (ac, a1, a2); - NEXT; + ARGS1 (a1); + RETURN (SCM_BOOL (!SCM_NULLP (a1))); } -SCM_DEFINE_VM_FUNCTION (list, "list", "list", 0, 1) +VM_DEFINE_FUNCTION (pairp, "pair?", 1) { - VM_SETUP_ARGSN (); - ac = SCM_EOL; - POP_LIST (nargs, ac); - NEXT; + ARGS1 (a1); + RETURN (SCM_BOOL (SCM_CONSP (a1))); } -SCM_DEFINE_VM_FUNCTION (car, "car", "car", 1, 0) +VM_DEFINE_FUNCTION (listp, "list?", 1) { - VM_SETUP_ARGS1 (); - SCM_VALIDATE_CONS (0, a1); - RETURN (SCM_CAR (a1)); + ARGS1 (a1); + RETURN (SCM_BOOL (scm_ilength (a1) >= 0)); } -SCM_DEFINE_VM_FUNCTION (cdr, "cdr", "cdr", 1, 0) +VM_DEFINE_FUNCTION (cons, "cons", 2) { - VM_SETUP_ARGS1 (); - SCM_VALIDATE_CONS (0, a1); - RETURN (SCM_CDR (a1)); + ARGS2 (a1, a2); + CONS (a1, a1, a2); + RETURN (a1); } -SCM_DEFINE_VM_FUNCTION (not, "not", "not", 1, 0) +VM_DEFINE_FUNCTION (car, "car", 1) { - VM_SETUP_ARGS1 (); - RETURN (SCM_BOOL (SCM_FALSEP (a1))); + ARGS1 (a1); + SCM_VALIDATE_CONS (1, a1); + RETURN (SCM_CAR (a1)); } -SCM_DEFINE_VM_FUNCTION (append, "append", "append", 0, 1) +VM_DEFINE_FUNCTION (cdr, "cdr", 1) { - VM_SETUP_ARGSN (); - ac = SCM_EOL; - POP_LIST (nargs, ac); - RETURN (scm_append (ac)); + ARGS1 (a1); + SCM_VALIDATE_CONS (1, a1); + RETURN (SCM_CDR (a1)); } -SCM_DEFINE_VM_FUNCTION (append_x, "append!", "append!", 0, 1) +VM_DEFINE_FUNCTION (set_car, "set-car!", 2) { - VM_SETUP_ARGSN (); - ac = SCM_EOL; - POP_LIST (nargs, ac); - RETURN (scm_append_x (ac)); + ARGS2 (a1, a2); + SCM_VALIDATE_CONS (1, a1); + SCM_SETCAR (a1, a2); + RETURN (SCM_UNSPECIFIED); } -SCM_DEFINE_VM_FUNCTION (catch, "catch", "catch", 3, 0) +VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2) { - VM_SETUP_ARGS3 (); - dynwinds = SCM_EOL; + ARGS2 (a1, a2); + SCM_VALIDATE_CONS (1, a1); + SCM_SETCDR (a1, a2); + RETURN (SCM_UNSPECIFIED); } -SCM_DEFINE_VM_FUNCTION (call_cc, "call-with-current-continuation", "call/cc", 1, 0) +VM_DEFINE_FUNCTION (list, "list", -1) { - SYNC (); /* must sync all registers */ - PUSH (SCM_VM_CAPTURE_CONT (vmp)); /* argument 1 */ - nargs = 1; /* the number of arguments */ - goto vm_call; + POP_LIST_MARK (); + NEXT; +} + +VM_DEFINE_FUNCTION (vector, "vector", -1) +{ + POP_LIST_MARK (); + *sp = scm_vector (*sp); + NEXT; } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/vm_system.c b/src/vm_system.c index de8041d96..3a4431e55 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -41,314 +41,257 @@ /* This file is included in vm_engine.c */ -/* - * Variable access - */ - -#define LOCAL_VAR(OFFSET) SCM_VM_FRAME_VARIABLE (fp, OFFSET) - -#define EXTERNAL_FOCUS(DEPTH) \ -{ \ - int depth = DEPTH; \ - env = ext; \ - while (depth-- > 0) \ - { \ - VM_ASSERT_LINK (env); \ - env = SCM_VM_EXTERNAL_LINK (env); \ - } \ -} - -#define EXTERNAL_VAR(OFFSET) SCM_VM_EXTERNAL_VARIABLE (env, OFFSET) -#define EXTERNAL_VAR0(OFFSET) SCM_VM_EXTERNAL_VARIABLE (ext, OFFSET) -#define EXTERNAL_VAR1(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (ext), OFFSET) -#define EXTERNAL_VAR2(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_VM_EXTERNAL_LINK (ext)), OFFSET) - /* * Basic operations */ -/* Must be the first instruction! */ -SCM_DEFINE_INSTRUCTION (nop, "%nop", INST_NONE) +/* This must be the first instruction! */ +VM_DEFINE_INSTRUCTION (nop, "nop", 0) { NEXT; } -SCM_DEFINE_INSTRUCTION (halt, "%halt", INST_NONE) +VM_DEFINE_INSTRUCTION (halt, "halt", 0) { - SYNC (); - VM_HALT_HOOK (); - return ac; + SCM ret = *sp; + HALT_HOOK (); + FREE_FRAME (); + SYNC_ALL (); + return ret; } -SCM_DEFINE_INSTRUCTION (name, "%name", INST_SCM) -{ - SCM name = FETCH (); - if (SCM_NIMP (name)) - scm_set_name_x (ac, name); - NEXT; -} - - -/* - * %push family - */ - -SCM_DEFINE_INSTRUCTION (push, "%push", INST_NONE) +VM_DEFINE_INSTRUCTION (drop, "drop", 0) { - PUSH (ac); + DROP (); NEXT; } -SCM_DEFINE_INSTRUCTION (push_list, "%push-list", INST_SCM) +VM_DEFINE_INSTRUCTION (dup, "dup", 0) { - SCM list; - for (list = FETCH (); SCM_NIMP (list); list = SCM_CDR (list)) - PUSH (SCM_CAR (list)); + PUSH (*sp); NEXT; } -SCM_DEFINE_INSTRUCTION (pushc, "%pushc", INST_SCM) -{ - PUSH (FETCH ()); - NEXT; -} - -SCM_DEFINE_INSTRUCTION (pushl, "%pushl", INST_INUM) -{ - PUSH (LOCAL_VAR (SCM_INUM (FETCH ()))); - NEXT; -} - -SCM_DEFINE_INSTRUCTION (pushl_0, "%pushl:0", INST_NONE) -{ - PUSH (LOCAL_VAR (0)); - NEXT; -} + +/* + * Object creation + */ -SCM_DEFINE_INSTRUCTION (pushl_1, "%pushl:1", INST_NONE) +VM_DEFINE_INSTRUCTION (void, "void", 0) { - PUSH (LOCAL_VAR (1)); + PUSH (SCM_UNSPECIFIED); NEXT; } -SCM_DEFINE_INSTRUCTION (pushe, "%pushe", INST_EXT) +VM_DEFINE_INSTRUCTION (mark, "mark", 0) { - SCM env; - SCM loc = FETCH (); - EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); - PUSH (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc)))); + PUSH (SCM_UNDEFINED); NEXT; } -SCM_DEFINE_INSTRUCTION (pushe_0, "%pushe:0", INST_INUM) +VM_DEFINE_INSTRUCTION (make_true, "make-true", 0) { - PUSH (EXTERNAL_VAR0 (SCM_INUM (FETCH ()))); + PUSH (SCM_BOOL_T); NEXT; } -SCM_DEFINE_INSTRUCTION (pushe_0_0, "%pushe:0:0", INST_NONE) +VM_DEFINE_INSTRUCTION (make_false, "make-false", 0) { - PUSH (EXTERNAL_VAR0 (0)); + PUSH (SCM_BOOL_F); NEXT; } -SCM_DEFINE_INSTRUCTION (pushe_0_1, "%pushe:0:1", INST_NONE) +VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0) { - PUSH (EXTERNAL_VAR0 (1)); + PUSH (SCM_EOL); NEXT; } -SCM_DEFINE_INSTRUCTION (pushe_1, "%pushe:1", INST_INUM) +VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1) { - PUSH (EXTERNAL_VAR1 (SCM_INUM (FETCH ()))); + PUSH (SCM_MAKINUM ((signed char) FETCH ())); NEXT; } -SCM_DEFINE_INSTRUCTION (pushe_1_0, "%pushe:1:0", INST_NONE) +VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0) { - PUSH (EXTERNAL_VAR1 (0)); + PUSH (SCM_MAKINUM (0)); NEXT; } -SCM_DEFINE_INSTRUCTION (pushe_1_1, "%pushe:1:1", INST_NONE) +VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0) { - PUSH (EXTERNAL_VAR1 (1)); + PUSH (SCM_MAKINUM (1)); NEXT; } -SCM_DEFINE_INSTRUCTION (pushe_2, "%pushe:2", INST_INUM) +VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2) { - PUSH (EXTERNAL_VAR2 (SCM_INUM (FETCH ()))); + PUSH (SCM_MAKINUM ((signed short) FETCH2 ())); NEXT; } -SCM_DEFINE_INSTRUCTION (pusht, "%pusht", INST_TOP) +VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1) { - ac = FETCH (); - VM_ASSERT_BOUND (ac); - PUSH (VM_VARIABLE_REF (ac)); + PUSH (SCM_MAKE_CHAR (FETCH ())); NEXT; } /* - * %load family + * Variable access */ -SCM_DEFINE_INSTRUCTION (load_unspecified, "%load-unspecified", INST_NONE) -{ - RETURN (SCM_UNSPECIFIED); -} - -SCM_DEFINE_INSTRUCTION (loadc, "%loadc", INST_SCM) -{ - RETURN (FETCH ()); -} - -SCM_DEFINE_INSTRUCTION (loadl, "%loadl", INST_INUM) -{ - RETURN (LOCAL_VAR (SCM_INUM (FETCH ()))); -} - -SCM_DEFINE_INSTRUCTION (loadl_0, "%loadl:0", INST_NONE) -{ - RETURN (LOCAL_VAR (0)); -} - -SCM_DEFINE_INSTRUCTION (loadl_1, "%loadl:1", INST_NONE) -{ - RETURN (LOCAL_VAR (1)); -} - -SCM_DEFINE_INSTRUCTION (loade, "%loade", INST_EXT) -{ - SCM env; - SCM loc = FETCH (); - EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); - RETURN (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc)))); -} +#define OBJECT_REF(i) objects[i] +#define OBJECT_SET(i,o) objects[i] = o -SCM_DEFINE_INSTRUCTION (loade_0, "%loade:0", INST_INUM) -{ - RETURN (EXTERNAL_VAR0 (SCM_INUM (FETCH ()))); -} +#define LOCAL_REF(i) SCM_VM_FRAME_VARIABLE (fp, i) +#define LOCAL_SET(i,o) SCM_VM_FRAME_VARIABLE (fp, i) = o -SCM_DEFINE_INSTRUCTION (loade_0_0, "%loade:0:0", INST_NONE) -{ - RETURN (EXTERNAL_VAR0 (0)); -} +#define VARIABLE_REF(v) SCM_CDR (v) +#define VARIABLE_SET(v,o) SCM_SETCDR (v, o) -SCM_DEFINE_INSTRUCTION (loade_0_1, "%loade:0:1", INST_NONE) +VM_DEFINE_INSTRUCTION (external, "external", 1) { - RETURN (EXTERNAL_VAR0 (1)); + int n = FETCH (); + while (n-- > 0) + CONS (external, SCM_UNDEFINED, external); + NEXT; } -SCM_DEFINE_INSTRUCTION (loade_1, "%loade:1", INST_INUM) -{ - RETURN (EXTERNAL_VAR1 (SCM_INUM (FETCH ()))); -} +/* ref */ -SCM_DEFINE_INSTRUCTION (loade_1_0, "%loade:1:0", INST_NONE) +VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1) { - RETURN (EXTERNAL_VAR1 (0)); + PUSH (OBJECT_REF (FETCH ())); + NEXT; } -SCM_DEFINE_INSTRUCTION (loade_1_1, "%loade:1:1", INST_NONE) +VM_DEFINE_INSTRUCTION (object_ref_2, "object-ref*2", 2) { - RETURN (EXTERNAL_VAR1 (1)); + PUSH (OBJECT_REF (FETCH2 ())); + NEXT; } -SCM_DEFINE_INSTRUCTION (loade_2, "%loade:2", INST_INUM) +VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1) { - RETURN (EXTERNAL_VAR2 (SCM_INUM (FETCH ()))); + PUSH (LOCAL_REF (FETCH ())); + NEXT; } -SCM_DEFINE_INSTRUCTION (loadt, "%loadt", INST_TOP) +VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0) { - ac = FETCH (); - VM_ASSERT_BOUND (ac); - RETURN (VM_VARIABLE_REF (ac)); -} - - -/* - * %save family - */ - -SCM_DEFINE_INSTRUCTION (savel, "%savel", INST_INUM) -{ - LOCAL_VAR (SCM_INUM (FETCH ())) = ac; + PUSH (LOCAL_REF (0)); NEXT; } -SCM_DEFINE_INSTRUCTION (savel_0, "%savel:0", INST_NONE) +VM_DEFINE_INSTRUCTION (local_ref_2, "local-ref*2", 2) { - LOCAL_VAR (0) = ac; + PUSH (LOCAL_REF (FETCH2 ())); NEXT; } -SCM_DEFINE_INSTRUCTION (savel_1, "%savel:1", INST_NONE) +VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1) { - LOCAL_VAR (1) = ac; + unsigned int i; + SCM e = external; + for (i = FETCH (); i; i--) + e = SCM_CDR (e); + PUSH (SCM_CAR (e)); NEXT; } -SCM_DEFINE_INSTRUCTION (savee, "%savee", INST_EXT) +VM_DEFINE_INSTRUCTION (module_ref, "module-ref", 1) { - SCM env; - SCM loc = FETCH (); - EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); - EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))) = ac; + int i = FETCH (); + SCM o, x = OBJECT_REF (i); + o = VARIABLE_REF (x); + if (SCM_UNBNDP (o)) + { + err_args = SCM_LIST1 (SCM_CAR (x)); + goto vm_error_unbound; + } + PUSH (o); NEXT; } -SCM_DEFINE_INSTRUCTION (savee_0, "%savee:0", INST_INUM) +VM_DEFINE_INSTRUCTION (module_ref_2, "module-ref*2", 2) { - EXTERNAL_VAR0 (SCM_INUM (FETCH ())) = ac; + int i = FETCH2 (); + SCM o, x = OBJECT_REF (i); + o = VARIABLE_REF (x); + if (SCM_UNBNDP (o)) + { + err_args = SCM_LIST1 (SCM_CAR (x)); + goto vm_error_unbound; + } + PUSH (o); NEXT; } -SCM_DEFINE_INSTRUCTION (savee_0_0, "%savee:0:0", INST_NONE) +VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0) { - EXTERNAL_VAR0 (0) = ac; + SCM x = *sp; + SCM o = VARIABLE_REF (x); + if (SCM_UNBNDP (o)) + { + err_args = SCM_LIST1 (SCM_CAR (x)); + goto vm_error_unbound; + } + *sp = o; NEXT; } -SCM_DEFINE_INSTRUCTION (savee_0_1, "%savee:0:1", INST_NONE) +/* set */ + +VM_DEFINE_INSTRUCTION (local_set, "local-set", 1) { - EXTERNAL_VAR0 (1) = ac; + LOCAL_SET (FETCH (), *sp); + DROP (); NEXT; } -SCM_DEFINE_INSTRUCTION (savee_1, "%savee:1", INST_INUM) +VM_DEFINE_INSTRUCTION (local_set_2, "local-set*2", 2) { - EXTERNAL_VAR1 (SCM_INUM (FETCH ())) = ac; + LOCAL_SET (FETCH2 (), *sp); + DROP (); NEXT; } -SCM_DEFINE_INSTRUCTION (savee_1_0, "%savee:1:0", INST_NONE) +VM_DEFINE_INSTRUCTION (external_set, "external-set", 1) { - EXTERNAL_VAR1 (0) = ac; + unsigned int i; + SCM e = external; + for (i = FETCH (); i; i--) + e = SCM_CDR (e); + SCM_SETCAR (e, *sp); + DROP (); NEXT; } -SCM_DEFINE_INSTRUCTION (savee_1_1, "%savee:1:1", INST_NONE) +VM_DEFINE_INSTRUCTION (module_set, "module-set", 1) { - EXTERNAL_VAR1 (1) = ac; + int i = FETCH (); + SCM x = OBJECT_REF (i); + VARIABLE_SET (x, *sp); + DROP (); NEXT; } -SCM_DEFINE_INSTRUCTION (savee_2, "%savee:2", INST_INUM) +VM_DEFINE_INSTRUCTION (module_set_2, "module-set*2", 2) { - EXTERNAL_VAR2 (SCM_INUM (FETCH ())) = ac; + int i = FETCH2 (); + SCM x = OBJECT_REF (i); + VARIABLE_SET (x, *sp); + DROP (); NEXT; } -SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP) +VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0) { - SCM cell = FETCH (); - VM_VARIABLE_SET (cell, ac); + VARIABLE_SET (sp[0], sp[1]); + sp += 2; NEXT; } @@ -357,47 +300,48 @@ SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP) * branch and jump */ -SCM_DEFINE_INSTRUCTION (br_if, "%br-if", INST_ADDR) +#define BR(p) \ +{ \ + signed char offset = FETCH (); \ + if (p) \ + ip += offset; \ + DROP (); \ + NEXT; \ +} + +VM_DEFINE_INSTRUCTION (br_if, "br-if", 1) { - SCM addr = FETCH (); /* must always fetch */ - if (!SCM_FALSEP (ac)) - pc = SCM_VM_ADDRESS (addr); - NEXT; + BR (!SCM_FALSEP (*sp)); } -SCM_DEFINE_INSTRUCTION (br_if_not, "%br-if-not", INST_ADDR) +VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1) { - SCM addr = FETCH (); /* must always fetch */ - if (SCM_FALSEP (ac)) - pc = SCM_VM_ADDRESS (addr); - NEXT; + BR (SCM_FALSEP (*sp)); } -SCM_DEFINE_INSTRUCTION (br_if_null, "%br-if-null", INST_ADDR) +VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1) { - SCM addr = FETCH (); /* must always fetch */ - if (SCM_NULLP (ac)) - { - ac = SCM_BOOL_T; - pc = SCM_VM_ADDRESS (addr); - } - NEXT; + BR (SCM_EQ_P (sp[0], sp--[1])); } -SCM_DEFINE_INSTRUCTION (br_if_not_null, "%br-if-not-null", INST_ADDR) +VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1) { - SCM addr = FETCH (); /* must always fetch */ - if (!SCM_NULLP (ac)) - { - ac = SCM_BOOL_F; - pc = SCM_VM_ADDRESS (addr); - } - NEXT; + BR (!SCM_EQ_P (sp[0], sp--[1])); +} + +VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1) +{ + BR (SCM_NULLP (*sp)); +} + +VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1) +{ + BR (!SCM_NULLP (*sp)); } -SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR) +VM_DEFINE_INSTRUCTION (jump, "jump", 1) { - pc = SCM_VM_ADDRESS (*pc); + ip += (signed char) FETCH (); NEXT; } @@ -406,159 +350,178 @@ SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR) * Subprogram call */ -SCM_DEFINE_INSTRUCTION (make_program, "%make-program", INST_CODE) +VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0) { - SYNC (); /* must be called before GC */ - RETURN (SCM_MAKE_PROGRAM (FETCH (), SCM_VM_FRAME_EXTERNAL_LINK (fp))); + SYNC (); + *sp = scm_c_make_vclosure (*sp, external); + NEXT; } -/* Before: - ac = program - pc[0] = the number of arguments - - After: - pc = program's address -*/ -SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) +VM_DEFINE_INSTRUCTION (call, "call", 1) { - nargs = SCM_INUM (FETCH ()); /* the number of arguments */ + POP (program); + nargs = FETCH (); vm_call: /* * Subprogram call */ - if (SCM_PROGRAM_P (ac)) + if (SCM_PROGRAM_P (program)) { - /* Create a new frame */ - SCM *last_fp = fp; - SCM *last_sp = sp + nargs; - VM_NEW_FRAME (fp, ac, - SCM_VM_MAKE_ADDRESS (last_fp), - SCM_VM_MAKE_ADDRESS (last_sp), - SCM_VM_MAKE_ADDRESS (pc)); - VM_CALL_HOOK (); - - /* Jump to the program */ - pc = SCM_PROGRAM_BASE (ac); - VM_APPLY_HOOK (); + CACHE_PROGRAM (); + INIT_ARGS (); + NEW_FRAME (); + INIT_VARIABLES (); + ENTER_HOOK (); + APPLY_HOOK (); NEXT; } /* * Function call */ - if (!SCM_FALSEP (scm_procedure_p (ac))) + if (!SCM_FALSEP (scm_procedure_p (program))) { - /* Construct an argument list */ - SCM list = SCM_EOL; - POP_LIST (nargs, list); - RETURN (scm_apply (ac, list, SCM_EOL)); + POP_LIST (nargs); + *sp = scm_apply (program, *sp, SCM_EOL); + program = SCM_VM_FRAME_PROGRAM (fp); + NEXT; } /* * Continuation call */ - if (SCM_VM_CONT_P (ac)) + if (SCM_VM_CONT_P (program)) { vm_call_cc: /* Check the number of arguments */ if (nargs != 1) - scm_wrong_num_args (ac); + scm_wrong_num_args (program); /* Reinstate the continuation */ - VM_RETURN_HOOK (); - SCM_VM_REINSTATE_CONT (vmp, ac); - LOAD (); - POP (ac); /* return value */ + EXIT_HOOK (); + reinstate_vm_cont (vmp, program); + CACHE (); + /* We don't need to set the return value here + because it is already on the top of the stack. */ NEXT; } - SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac)); + goto vm_error_wrong_type_apply; } -/* Before: - ac = program - pc[0] = the number of arguments - - After: - pc = program's address -*/ -SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) +VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1) { - SCM_TICK; /* allow interrupt here */ - nargs = SCM_INUM (FETCH ()); /* the number of arguments */ + SCM x; + POP (x); + nargs = FETCH (); + + SCM_TICK; /* allow interrupt here */ /* - * Subprogram call + * Tail recursive call */ - if (SCM_PROGRAM_P (ac)) + if (SCM_EQ_P (x, program)) { - if (SCM_EQ_P (ac, SCM_VM_FRAME_PROGRAM (fp))) - /* Tail recursive call */ - { - /* Setup arguments */ - int nvars = SCM_PROGRAM_NVARS (ac); /* the number of local vars */ - int nreqs = SCM_PROGRAM_NREQS (ac); /* the number of require args */ - int restp = SCM_PROGRAM_RESTP (ac); /* have a rest argument */ - VM_FRAME_INIT_ARGS (ac, nreqs, restp); - - /* Move arguments */ - nreqs += restp; - while (nreqs-- > 0) - { - SCM obj; - POP (obj); - SCM_VM_FRAME_VARIABLE (fp, nvars++) = obj; - } - - VM_FRAME_INIT_EXTERNAL_VARIABLES (fp, ac); - } - else - /* Proper tail call */ + INIT_ARGS (); + + /* Move arguments */ + if (bp->nargs) { - /* FIXME: Must remove the last frame. - FIXME: We need to move arguments before that. */ - SCM *last_fp = fp; - VM_RETURN_HOOK (); - VM_NEW_FRAME (fp, ac, - SCM_VM_FRAME_DYNAMIC_LINK (last_fp), - SCM_VM_FRAME_STACK_POINTER (last_fp), - SCM_VM_FRAME_RETURN_ADDRESS (last_fp)); - VM_CALL_HOOK (); + int i; + SCM *base = fp + bp->nlocs; + for (i = 0; i < bp->nargs; i++) + base[i] = sp[i]; } - /* Jump to the program */ - pc = SCM_PROGRAM_BASE (ac); - VM_APPLY_HOOK (); + ip = bp->base; + sp = SCM_VM_FRAME_LOWER_ADDRESS (fp); + APPLY_HOOK (); NEXT; } + program = x; + /* + * Proper tail call + */ + if (SCM_PROGRAM_P (program)) + { + int i; + int n = SCM_VM_FRAME_LOWER_ADDRESS (fp) - sp; + SCM *base = sp; + + /* Exit the current frame */ + EXIT_HOOK (); + FREE_FRAME (); + + /* Move arguments */ + sp -= n; + for (i = 0; i < n; i++) + sp[i] = base[i]; + + /* Call the program */ + goto vm_call; + } /* * Function call */ - if (!SCM_FALSEP (scm_procedure_p (ac))) + if (!SCM_FALSEP (scm_procedure_p (program))) { - /* Construct an argument list */ - SCM list = SCM_EOL; - POP_LIST (nargs, list); - ac = scm_apply (ac, list, SCM_EOL); + POP_LIST (nargs); + *sp = scm_apply (program, *sp, SCM_EOL); + program = SCM_VM_FRAME_PROGRAM (fp); goto vm_return; } /* * Continuation call */ - if (SCM_VM_CONT_P (ac)) + if (SCM_VM_CONT_P (program)) goto vm_call_cc; - SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac)); + goto vm_error_wrong_type_apply; +} + +VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1) +{ + SYNC (); + PUSH (capture_vm_cont (vmp)); + POP (program); + nargs = 1; + goto vm_call; } -SCM_DEFINE_INSTRUCTION (return, "%return", INST_NONE) +VM_DEFINE_INSTRUCTION (return, "return", 0) { - SCM *last_fp; + SCM ret; vm_return: - VM_RETURN_HOOK (); - last_fp = fp; - fp = SCM_VM_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (last_fp)); - sp = SCM_VM_ADDRESS (SCM_VM_FRAME_STACK_POINTER (last_fp)); - pc = SCM_VM_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (last_fp)); - ext = SCM_VM_FRAME_EXTERNAL_LINK (fp); + ret = *sp; + EXIT_HOOK (); + RETURN_HOOK (); + FREE_FRAME (); + + /* Cache the last program */ + program = SCM_VM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); + PUSH (ret); NEXT; } + + +/* + * Exception handling + */ + +VM_DEFINE_INSTRUCTION (raise, "raise", 1) +{ +} + +VM_DEFINE_INSTRUCTION (catch, "catch", 0) +{ +} + +VM_DEFINE_INSTRUCTION (stack_catch, "stach_catch", 0) +{ +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ -- cgit v1.2.3 From ff6736271135b7598992c2084b131c7f70c9a3bc Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 1 Apr 2001 05:10:15 +0000 Subject: *** empty log message *** --- module/Makefile.am | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/module/Makefile.am b/module/Makefile.am index aa748128e..e69de29bb 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1,13 +0,0 @@ -guiledatadir = $(datadir)/guile - -install-data-local: - $(mkinstalldirs) $(DESTDIR)$(guiledatadir) - cp -rp module/* $(DESTDIR)$(guiledatadir) - rm -f $(guiledatadir)/system/vm/libcore.so \ - && $(LN_S) $(libdir)/libguilevm.so $(guiledatadir)/system/vm/libcore.so - -install-data-local: - $(mkinstalldirs) $(DESTDIR)$(guiledatadir) - cp -rp module/* $(DESTDIR)$(guiledatadir) - rm -f $(guiledatadir)/system/vm/libcore.so \ - && $(LN_S) $(libdir)/libguilevm.so $(guiledatadir)/system/vm/libcore.so -- cgit v1.2.3 From 296ad2b47f63bc86d4468ca7a8754fcbd51a706a Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 1 Apr 2001 05:33:45 +0000 Subject: New files. --- module/language/r5rs/GPKG.def | 12 + module/language/r5rs/core.il | 325 + module/language/r5rs/expand.scm | 82 + module/language/r5rs/null.il | 18 + module/language/r5rs/psyntax.boot | 72 + module/language/r5rs/psyntax.pp | 14552 +++++++++++++++++++++++++++++++++++ module/language/r5rs/psyntax.scm | 1 + module/language/r5rs/psyntax.ss | 3197 ++++++++ module/language/r5rs/spec.scm | 37 + module/language/r5rs/translate.scm | 59 + 10 files changed, 18355 insertions(+) create mode 100644 module/language/r5rs/GPKG.def create mode 100644 module/language/r5rs/core.il create mode 100644 module/language/r5rs/expand.scm create mode 100644 module/language/r5rs/null.il create mode 100644 module/language/r5rs/psyntax.boot create mode 100644 module/language/r5rs/psyntax.pp create mode 100644 module/language/r5rs/psyntax.scm create mode 100644 module/language/r5rs/psyntax.ss create mode 100644 module/language/r5rs/spec.scm create mode 100644 module/language/r5rs/translate.scm diff --git a/module/language/r5rs/GPKG.def b/module/language/r5rs/GPKG.def new file mode 100644 index 000000000..5ad52e8c6 --- /dev/null +++ b/module/language/r5rs/GPKG.def @@ -0,0 +1,12 @@ +;;; r5rs package definition -*- gscheme -*- + +(define-package r5rs + :category Language + :version "0.3" + :author "Keisuke Nishida " + :modules ((core "core.il" ghil) + (null "null.il" ghil) + (spec "spec.scm" gscheme) + (expand "expand.scm" gscheme) + (translate "translate.scm" gscheme)) + ) diff --git a/module/language/r5rs/core.il b/module/language/r5rs/core.il new file mode 100644 index 000000000..1e282ea5a --- /dev/null +++ b/module/language/r5rs/core.il @@ -0,0 +1,325 @@ +;;; R5RS core environment + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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 VM 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 VM; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; 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-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-ci? (@ Core::string-ci>?)) +(@define string-ci<=? (@ Core::string-ci<=?)) +(@define string-ci>=? (@ Core::string-ci>=?)) + +(@define substring (@ Core::substring)) +(@define string-append (@ Core::string-append)) +(@define string->list (@ Core::string->list)) +(@define list->string (@ Core::list->string)) +(@define string-copy (@ Core::string-copy)) +(@define string-fill! (@ Core::string-fill!)) + +;;;; 6.3.6 Vectors + +(@define vector? (@ Core::vector?)) +(@define make-vector (@ Core::make-vector)) +(@define vector (@ Core::vector)) +(@define vector-length (@ Core::vector-length)) +(@define vector-ref (@ Core::vector-ref)) +(@define vector-set! (@ Core::vector-set!)) +(@define vector->list (@ Core::vector->list)) +(@define list->vector (@ Core::list->vector)) +(@define vector-fill! (@ Core::vector-fill!)) + +;;; 6.4 Control features + +(@define procedure? (@ Core::procedure?)) +(@define apply (@ Core::apply)) +(@define map (@ Core::map)) +(@define for-each (@ Core::for-each)) +(@define force (@ Core::force)) + +(@define call-with-current-continuation (@ Core::call-with-current-continuation)) +(@define values (@ Core::values)) +(@define call-with-values (@ Core::call-with-values)) +(@define dynamic-wind (@ Core::dynamic-wind)) + +;;; 6.5 Eval + +(@define eval + (@let ((l (@ Language::r5rs::spec::r5rs))) + (@lambda (x e) + (((@ System::Base::language::compile-in) x e l))))) + +;; (@define scheme-report-environment +;; (@lambda (version) +;; (@if (@= version 5) +;; (@ Language::R5RS::Core) +;; (@error "Unsupported environment version" version)))) +;; +;; (@define null-environment +;; (@lambda (version) +;; (@if (@= version 5) +;; (@ Language::R5RS::Null) +;; (@error "Unsupported environment version" version)))) + +(@define interaction-environment (@lambda () (@current-module))) + +;;; 6.6 Input and output + +;;;; 6.6.1 Ports + +(@define call-with-input-file (@ Core::call-with-input-file)) +(@define call-with-output-file (@ Core::call-with-output-file)) + +(@define input-port? (@ Core::input-port?)) +(@define output-port? (@ Core::output-port?)) +(@define current-input-port (@ Core::current-input-port)) +(@define current-output-port (@ Core::current-output-port)) + +(@define with-input-from-file (@ Core::with-input-from-file)) +(@define with-output-to-file (@ Core::with-output-to-file)) + +(@define open-input-file (@ Core::open-input-file)) +(@define open-output-file (@ Core::open-output-file)) +(@define close-input-port (@ Core::close-input-port)) +(@define close-output-port (@ Core::close-output-port)) + +;;;; 6.6.2 Input + +(@define read (@ Core::read)) +(@define read-char (@ Core::read-char)) +(@define peek-char (@ Core::peek-char)) +(@define eof-object? (@ Core::eof-object?)) +(@define char-ready? (@ Core::char-ready?)) + +;;;; 6.6.3 Output + +(@define write (@ Core::write)) +(@define display (@ Core::display)) +(@define newline (@ Core::newline)) +(@define write-char (@ Core::write-char)) + +;;;; 6.6.4 System interface + +(@define load + (@lambda (file) + (call-with-input-file file + (@lambda (port) + (@let ((loop (@lambda (x) + (@if (@not (eof-object? x)) + (@begin + (eval x (interaction-environment)) + (loop (read port))))))) + (loop (read port))))))) + +;; transcript-on +;; transcript-off diff --git a/module/language/r5rs/expand.scm b/module/language/r5rs/expand.scm new file mode 100644 index 000000000..900c2a30a --- /dev/null +++ b/module/language/r5rs/expand.scm @@ -0,0 +1,82 @@ +;;;; Copyright (C) 1997, 2000 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 +;;;; + + +(define-module (language r5rs expand) + :export (expand + 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 (sc-eval x) (eval x syncase-module)) + +(load "psyntax.scm") + +(define expand sc-expand) + +(define (rebuild) + (call-with-input-file "psyntax.ss" + (lambda (in) + (call-with-output-file "psyntax.scm" + (lambda (out) + (do ((obj (read in) (read in))) + ((eof-object? obj)) + (write (sc-expand obj 'c '(eval load compile)) out))))))) + +;(rebuild) diff --git a/module/language/r5rs/null.il b/module/language/r5rs/null.il new file mode 100644 index 000000000..3d63b9b00 --- /dev/null +++ b/module/language/r5rs/null.il @@ -0,0 +1,18 @@ +;;; R5RS null environment + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; Guile VM 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 VM 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 VM; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. diff --git a/module/language/r5rs/psyntax.boot b/module/language/r5rs/psyntax.boot new file mode 100644 index 000000000..e47c0ec80 --- /dev/null +++ b/module/language/r5rs/psyntax.boot @@ -0,0 +1,72 @@ +;;;; Copyright (C) 1997, 2000 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 +;;;; + + +(define sc-expand #f) +(define $sc-put-cte #f) +(define bound-identifier=? #f) +(define datum->syntax-object #f) +(define free-identifier=? #f) +(define generate-temporaries #f) +(define identifier? #f) +(define syntax-object->datum #f) +(define syntax-rules #f) +(define syntax-error #f) +(define $syntax-dispatch #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 core-eval eval) +(define (eval x) (core-eval (cadr x) (interaction-environment))) + +(load "psyntax.pp") + +(call-with-input-file "psyntax.ss" + (lambda (in) + (call-with-output-file "psyntax.scm" + (lambda (out) + (do ((obj (read in) (read in))) + ((eof-object? obj)) + (write (sc-expand obj) out)))))) diff --git a/module/language/r5rs/psyntax.pp b/module/language/r5rs/psyntax.pp new file mode 100644 index 000000000..4ee7eb241 --- /dev/null +++ b/module/language/r5rs/psyntax.pp @@ -0,0 +1,14552 @@ +;;; psyntax.pp +;;; automatically generated from psyntax.ss +;;; Wed Aug 30 12:24:52 EST 2000 +;;; see copyright notice in psyntax.ss + +((lambda () + (letrec ((g452 + (lambda (g1823) + ((letrec ((g1824 + (lambda (g1827 g1825 g1826) + (if (pair? g1827) + (g1824 + (cdr g1827) + (cons (g393 (car g1827) g1826) g1825) + g1826) + (if (g256 g1827) + (cons (g393 g1827 g1826) g1825) + (if (null? g1827) + g1825 + (if (g204 g1827) + (g1824 + (g205 g1827) + g1825 + (g371 g1826 (g206 g1827))) + (if (g90 g1827) + (g1824 + (annotation-expression + g1827) + g1825 + g1826) + (cons g1827 g1825))))))))) + g1824) + g1823 + '() + '(())))) + (g451 + (lambda (g833) + ((lambda (g834) (if (g90 g834) (gensym) (gensym))) + (if (g204 g833) (g205 g833) g833)))) + (g450 + (lambda (g1820 g1819) + (g449 g1820 + g1819 + (lambda (g1821) + (if ((lambda (g1822) + (if g1822 + g1822 + (if (pair? g1821) + (g90 (car g1821)) + '#f))) + (g90 g1821)) + (g448 g1821 '#f) + g1821))))) + (g449 + (lambda (g837 g835 g836) + (if (memq 'top (g264 g835)) + (g836 g837) + ((letrec ((g838 + (lambda (g839) + (if (g204 g839) + (g449 (g205 g839) (g206 g839) g836) + (if (pair? g839) + ((lambda (g841 g840) + (if (if (eq? g841 (car g839)) + (eq? g840 (cdr g839)) + '#f) + g839 + (cons g841 g840))) + (g838 (car g839)) + (g838 (cdr g839))) + (if (vector? g839) + ((lambda (g842) + ((lambda (g843) + (if (andmap + eq? + g842 + g843) + g839 + (list->vector g843))) + (map g838 g842))) + (vector->list g839)) + g839)))))) + g838) + g837)))) + (g448 + (lambda (g1813 g1812) + (if (pair? g1813) + ((lambda (g1814) + (begin (if g1812 + (set-annotation-stripped! g1812 g1814) + (void)) + (set-car! g1814 (g448 (car g1813) '#f)) + (set-cdr! g1814 (g448 (cdr g1813) '#f)) + g1814)) + (cons '#f '#f)) + (if (g90 g1813) + ((lambda (g1815) + (if g1815 + g1815 + (g448 (annotation-expression g1813) g1813))) + (annotation-stripped g1813)) + (if (vector? g1813) + ((lambda (g1816) + (begin (if g1812 + (set-annotation-stripped! + g1812 + g1816) + (void)) + ((letrec ((g1817 + (lambda (g1818) + (if (not (< g1818 '0)) + (begin (vector-set! + g1816 + g1818 + (g448 (vector-ref + g1813 + g1818) + '#f)) + (g1817 + (- g1818 + '1))) + (void))))) + g1817) + (- (vector-length g1813) '1)) + g1816)) + (make-vector (vector-length g1813))) + g1813))))) + (g447 + (lambda (g844) + (if (g255 g844) + (g378 g844 + '#(syntax-object + ... + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage ((import-token . *top*)) () ()) + #(ribcage ((import-token . *top*)) () ())))) + '#f))) + (g446 (lambda () (list 'void))) + (g445 + (lambda (g850 g845 g849 g846 g848 g847) + ((lambda (g851) + ((lambda (g852) + (if g852 + (apply + (lambda (g857 g853 g856 g854 g855) + ((lambda (g858) + (if (not (g389 g858)) + (g391 (map (lambda (g859) + (g393 g859 g846)) + g858) + (g394 g845 g846 g848) + '"keyword") + ((lambda (g860) + ((lambda (g861) + (g847 (cons g854 g855) + (g247 g860 + ((lambda (g863 g862) + (map (lambda (g865) + (g231 'deferred + (g432 g865 + g862 + g863))) + g856)) + (if g850 g861 g846) + (g249 g849)) + g849) + g861 + g848)) + (g368 g858 g860 g846))) + (g299 g858)))) + g853)) + g852) + ((lambda (g868) + (syntax-error (g394 g845 g846 g848))) + g851))) + ($syntax-dispatch + g851 + '(any #(each (any any)) any . each-any)))) + g845))) + (g444 + (lambda (g1789 g1785 g1788 g1786 g1787) + ((lambda (g1790) + ((lambda (g1791) + (if g1791 + (apply + (lambda (g1794 g1792 g1793) + ((lambda (g1795) + (if (not (g389 g1795)) + (syntax-error + g1789 + '"invalid parameter list in") + ((lambda (g1797 g1796) + (g1787 + g1796 + (g437 (cons g1792 g1793) + g1789 + (g248 g1797 g1796 g1788) + (g368 g1795 g1797 g1786)))) + (g299 g1795) + (map g451 g1795)))) + g1794)) + g1791) + ((lambda (g1800) + (if g1800 + (apply + (lambda (g1803 g1801 g1802) + ((lambda (g1804) + (if (not (g389 g1804)) + (syntax-error + g1789 + '"invalid parameter list in") + ((lambda (g1806 g1805) + (g1787 + ((letrec ((g1808 + (lambda (g1810 + g1809) + (if (null? + g1810) + g1809 + (g1808 + (cdr g1810) + (cons (car g1810) + g1809)))))) + g1808) + (cdr g1805) + (car g1805)) + (g437 (cons g1801 g1802) + g1789 + (g248 g1806 + g1805 + g1788) + (g368 g1804 + g1806 + g1786)))) + (g299 g1804) + (map g451 g1804)))) + (g452 g1803))) + g1800) + ((lambda (g1811) (syntax-error g1789)) + g1790))) + ($syntax-dispatch g1790 '(any any . each-any))))) + ($syntax-dispatch g1790 '(each-any any . each-any)))) + g1785))) + (g443 + (lambda (g872 g869 g871 g870) + ((lambda (g873) + ((lambda (g874) + (if (if g874 + (apply + (lambda (g877 g875 g876) (g256 g875)) + g874) + '#f) + (apply + (lambda (g880 g878 g879) (g870 g878 g879 g869)) + g874) + ((lambda (g881) + (syntax-error (g394 g872 g869 g871))) + g873))) + ($syntax-dispatch g873 '(any any any)))) + g872))) + (g442 + (lambda (g1758 g1755 g1757 g1756) + ((lambda (g1759) + ((lambda (g1760) + (if (if g1760 + (apply + (lambda (g1763 g1761 g1762) (g256 g1761)) + g1760) + '#f) + (apply + (lambda (g1766 g1764 g1765) + (g1756 g1764 g1765 g1755)) + g1760) + ((lambda (g1767) + (if (if g1767 + (apply + (lambda (g1772 + g1768 + g1771 + g1769 + g1770) + (if (g256 g1768) + (g389 (g452 g1771)) + '#f)) + g1767) + '#f) + (apply + (lambda (g1777 g1773 g1776 g1774 g1775) + (g1756 + (g393 g1773 g1755) + (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ name args e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e w s k) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()) + #(ribcage + ((import-token . *top*)) + () + ()))) + (g393 (cons g1776 + (cons g1774 g1775)) + g1755)) + '(()))) + g1767) + ((lambda (g1779) + (if (if g1779 + (apply + (lambda (g1781 g1780) + (g256 g1780)) + g1779) + '#f) + (apply + (lambda (g1783 g1782) + (g1756 + (g393 g1782 g1755) + '(#(syntax-object + void + ((top) + #(ribcage + #(_ name) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(e w s k) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + '(()))) + g1779) + ((lambda (g1784) + (syntax-error + (g394 g1758 g1755 g1757))) + g1759))) + ($syntax-dispatch g1759 '(any any))))) + ($syntax-dispatch + g1759 + '(any (any . any) any . each-any))))) + ($syntax-dispatch g1759 '(any any any)))) + g1758))) + (g441 + (lambda (g885 g882 g884 g883) + ((lambda (g886) + ((lambda (g887) + (if (if g887 + (apply (lambda (g889 g888) (g256 g888)) g887) + '#f) + (apply + (lambda (g891 g890) (g883 (g393 g890 g882))) + g887) + ((lambda (g892) + (syntax-error (g394 g885 g882 g884))) + g886))) + ($syntax-dispatch g886 '(any any)))) + g885))) + (g440 + (lambda (g1723 g1719 g1722 g1720 g1721) + (letrec ((g1725 + (lambda (g1753 g1751 g1752) + (g1721 + g1753 + (g1724 g1751) + (map (lambda (g1754) (g393 g1754 g1720)) + g1752)))) + (g1724 + (lambda (g1745) + (if (null? g1745) + '() + (cons ((lambda (g1746) + ((lambda (g1747) + (if g1747 + (apply + (lambda (g1748) + (g1724 g1748)) + g1747) + ((lambda (g1750) + (if (g256 g1750) + (g393 g1750 g1720) + (syntax-error + (g394 g1723 + g1719 + g1722) + '"invalid exports list in"))) + g1746))) + ($syntax-dispatch + g1746 + 'each-any))) + (car g1745)) + (g1724 (cdr g1745))))))) + ((lambda (g1726) + ((lambda (g1727) + (if g1727 + (apply + (lambda (g1730 g1728 g1729) + (g1725 '#f g1728 g1729)) + g1727) + ((lambda (g1733) + (if (if g1733 + (apply + (lambda (g1737 g1734 g1736 g1735) + (g256 g1734)) + g1733) + '#f) + (apply + (lambda (g1741 g1738 g1740 g1739) + (g1725 + (g393 g1738 g1719) + g1740 + g1739)) + g1733) + ((lambda (g1744) + (syntax-error + (g394 g1723 g1719 g1722))) + g1726))) + ($syntax-dispatch + g1726 + '(any any each-any . each-any))))) + ($syntax-dispatch g1726 '(any each-any . each-any)))) + g1723)))) + (g439 + (lambda (g894 g893) + ((lambda (g895) + (if g895 + (g366 g893 g895) + (g429 (lambda (g896) + ((lambda (g897) + (begin (if (not g897) + (syntax-error + g896 + '"exported identifier not visible") + (void)) + (g363 g893 g896 g897))) + (g376 g896 '(())))) + (g404 g894)))) + (g405 g894)))) + (g438 + (lambda (g1652 g1648 g1651 g1649 g1650) + (letrec ((g1653 + (lambda (g1718 g1714 g1717 g1715 g1716) + (begin (g426 g1648 g1714) + (g1650 g1718 g1714 g1717 g1715 g1716))))) + ((letrec ((g1654 + (lambda (g1659 g1655 g1658 g1656 g1657) + (if (null? g1659) + (g1653 g1659 g1655 g1658 g1656 g1657) + ((lambda (g1661 g1660) + (call-with-values + (lambda () + (g398 g1661 + g1660 + '(()) + '#f + g1652)) + (lambda (g1666 + g1662 + g1665 + g1663 + g1664) + ((lambda (g1667) + (if (memv g1667 '(define-form)) + (g442 g1665 + g1663 + g1664 + (lambda (g1670 + g1668 + g1669) + ((lambda (g1672 + g1671) + ((lambda (g1673) + (begin (g363 g1652 + g1672 + g1671) + (g424 g1649 + g1671 + (g231 'lexical + g1673)) + (g1654 + (cdr g1659) + (cons g1672 + g1655) + (cons g1673 + g1658) + (cons (cons g1660 + (g393 g1668 + g1669)) + g1656) + g1657))) + (g451 g1672))) + (g393 g1670 g1669) + (g297)))) + (if (memv g1667 + '(define-syntax-form)) + (g443 g1665 + g1663 + g1664 + (lambda (g1676 + g1674 + g1675) + ((lambda (g1679 + g1677 + g1678) + (begin (g363 g1652 + g1679 + g1677) + (g424 g1649 + g1677 + (g231 'deferred + g1678)) + (g1654 + (cdr g1659) + (cons g1679 + g1655) + g1658 + g1656 + g1657))) + (g393 g1676 + g1675) + (g297) + (g432 g1674 + (g249 g1660) + g1675)))) + (if (memv g1667 + '(module-form)) + ((lambda (g1680) + ((lambda (g1681) + ((lambda () + (g440 g1665 + g1663 + g1664 + g1681 + (lambda (g1684 + g1682 + g1683) + (g438 g1680 + (g394 g1665 + g1663 + g1664) + (map (lambda (g1695) + (cons g1660 + g1695)) + g1683) + g1649 + (lambda (g1689 + g1685 + g1688 + g1686 + g1687) + (begin (g425 g1648 + (g401 g1682) + g1685) + ((lambda (g1693 + g1690 + g1692 + g1691) + (if g1684 + ((lambda (g1694) + (begin (g363 g1652 + g1684 + g1694) + (g424 g1649 + g1694 + (g231 'module + g1693)) + (g1654 + (cdr g1659) + (cons g1684 + g1655) + g1690 + g1692 + g1691))) + (g297)) + ((lambda () + (begin (g439 g1693 + g1652) + (g1654 + (cdr g1659) + (cons g1693 + g1655) + g1690 + g1692 + g1691)))))) + (g408 g1682) + (append + g1688 + g1658) + (append + g1686 + g1656) + (append + g1657 + g1687 + g1689)))))))))) + (g263 (g264 g1663) + (cons g1680 + (g265 g1663))))) + (g304 '() + '() + '())) + (if (memv g1667 + '(import-form)) + (g441 g1665 + g1663 + g1664 + (lambda (g1696) + ((lambda (g1697) + ((lambda (g1698) + ((lambda (g1699) + (if (memv g1699 + '(module)) + ((lambda (g1700) + (begin (if g1662 + (g364 g1652 + g1662) + (void)) + (g439 g1700 + g1652) + (g1654 + (cdr g1659) + (cons g1700 + g1655) + g1658 + g1656 + g1657))) + (cdr g1698)) + (if (memv g1699 + '(displaced-lexical)) + (g250 g1696) + (syntax-error + g1696 + '"import from unknown module")))) + (car g1698))) + (g253 g1697 + g1649))) + (g377 g1696 + '(()))))) + (if (memv g1667 + '(begin-form)) + ((lambda (g1701) + ((lambda (g1702) + (if g1702 + (apply + (lambda (g1704 + g1703) + (g1654 + ((letrec ((g1705 + (lambda (g1706) + (if (null? + g1706) + (cdr g1659) + (cons (cons g1660 + (g393 (car g1706) + g1663)) + (g1705 + (cdr g1706))))))) + g1705) + g1703) + g1655 + g1658 + g1656 + g1657)) + g1702) + (syntax-error + g1701))) + ($syntax-dispatch + g1701 + '(any . + each-any)))) + g1665) + (if (memv g1667 + '(local-syntax-form)) + (g445 g1662 + g1665 + g1660 + g1663 + g1664 + (lambda (g1711 + g1708 + g1710 + g1709) + (g1654 + ((letrec ((g1712 + (lambda (g1713) + (if (null? + g1713) + (cdr g1659) + (cons (cons g1708 + (g393 (car g1713) + g1710)) + (g1712 + (cdr g1713))))))) + g1712) + g1711) + g1655 + g1658 + g1656 + g1657))) + (g1653 + (cons (cons g1660 + (g394 g1665 + g1663 + g1664)) + (cdr g1659)) + g1655 + g1658 + g1656 + g1657)))))))) + g1666)))) + (cdar g1659) + (caar g1659)))))) + g1654) + g1651 + '() + '() + '() + '())))) + (g437 + (lambda (g901 g898 g900 g899) + ((lambda (g902) + ((lambda (g903) + ((lambda (g904) + ((lambda (g905) + ((lambda () + (g438 g903 + g898 + g905 + g902 + (lambda (g910 g906 g909 g907 g908) + (begin (if (null? g910) + (syntax-error + g898 + '"no expressions in body") + (void)) + (g191 '#f + g909 + (map (lambda (g912) + (g432 (cdr g912) + (car g912) + '(()))) + g907) + (g190 '#f + (map (lambda (g911) + (g432 (cdr g911) + (car g911) + '(()))) + (append + g908 + g910)))))))))) + (map (lambda (g913) (cons g902 (g393 g913 g904))) + g901))) + (g263 (g264 g899) (cons g903 (g265 g899))))) + (g304 '() '() '()))) + (cons '("placeholder" placeholder) g900)))) + (g436 + (lambda (g1635 g1630 g1634 g1631 g1633 g1632) + (letrec ((g1636 + (lambda (g1640 g1639) + (if (pair? g1640) + (cons (g1636 (car g1640) g1639) + (g1636 (cdr g1640) g1639)) + (if (g204 g1640) + ((lambda (g1641) + ((lambda (g1643 g1642) + (g203 (g205 g1640) + (if (if (pair? g1643) + (eq? (car g1643) + '#f) + '#f) + (g263 (cdr g1643) + (if g1632 + (cons g1632 + (cdr g1642)) + (cdr g1642))) + (g263 (cons g1639 g1643) + (if g1632 + (cons g1632 + (cons 'shift + g1642)) + (cons 'shift + g1642)))))) + (g264 g1641) + (g265 g1641))) + (g206 g1640)) + (if (vector? g1640) + ((lambda (g1644) + ((lambda (g1645) + ((lambda () + ((letrec ((g1646 + (lambda (g1647) + (if (= g1647 + g1644) + g1645 + (begin (vector-set! + g1645 + g1647 + (g1636 + (vector-ref + g1640 + g1647) + g1639)) + (g1646 + (+ g1647 + '1))))))) + g1646) + '0)))) + (make-vector g1644))) + (vector-length g1640)) + (if (symbol? g1640) + (syntax-error + (g394 g1630 g1631 g1633) + '"encountered raw symbol " + (format '"~s" g1640) + '" in output of macro") + g1640))))))) + (g1636 + ((lambda (g1637) + (if (procedure? g1637) + (g1637 + (lambda (g1638) + (begin (if (not (identifier? g1638)) + (syntax-error + g1638 + '"environment argument is not an identifier") + (void)) + (g253 (g377 g1638 '(())) g1634)))) + g1637)) + (g1635 (g394 g1630 (g349 g1631) g1633))) + (string '#\m))))) + (g435 + (lambda (g918 g914 g917 g915 g916) + ((lambda (g919) + ((lambda (g920) + (if (if g920 + (apply + (lambda (g923 g921 g922) (g256 g921)) + g920) + '#f) + (apply + (lambda (g926 g924 g925) + ((lambda (g927) + ((lambda (g928) + ((lambda (g929) + (if (memv g929 '(macro!)) + ((lambda (g931 g930) + (g398 (g436 (g233 g928) + (list '#(syntax-object + set! + ((top) + #(ribcage + () + () + ()) + #(ribcage + #(id + val) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(t) + #(("m" top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(b) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(n) + #((top)) + #("i")) + #(ribcage + #(_ + id + val) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g931 + g930) + g914 + '(()) + g915 + g916) + g914 + '(()) + g915 + g916)) + (g393 g924 g917) + (g393 g925 g917)) + (values + 'core + (lambda (g935 g932 g934 g933) + ((lambda (g937 g936) + ((lambda (g938) + ((lambda (g939) + (if (memv g939 + '(lexical)) + (list 'set! + (g233 g938) + g937) + (if (memv g939 + '(global)) + (list 'set! + (g233 g938) + g937) + (if (memv g939 + '(displaced-lexical)) + (syntax-error + (g393 g924 + g934) + '"identifier out of context") + (syntax-error + (g394 g935 + g934 + g933)))))) + (g232 g938))) + (g253 g936 g932))) + (g432 g925 g932 g934) + (g377 g924 g934))) + g918 + g917 + g915))) + (g232 g928))) + (g253 g927 g914))) + (g377 g924 g917))) + g920) + ((lambda (g940) + (syntax-error (g394 g918 g917 g915))) + g919))) + ($syntax-dispatch g919 '(any any any)))) + g918))) + (g434 + (lambda (g1622 g1618 g1621 g1619 g1620) + ((lambda (g1623) + ((lambda (g1624) + (if g1624 + (apply + (lambda (g1626 g1625) + (cons g1622 + (map (lambda (g1628) + (g432 g1628 g1621 g1619)) + g1625))) + g1624) + ((lambda (g1629) + (syntax-error (g394 g1618 g1619 g1620))) + g1623))) + ($syntax-dispatch g1623 '(any . each-any)))) + g1618))) + (g433 + (lambda (g946 g941 g945 g942 g944 g943) + ((lambda (g947) + (if (memv g947 '(lexical)) + g941 + (if (memv g947 '(core)) + (g941 g945 g942 g944 g943) + (if (memv g947 '(lexical-call)) + (g434 g941 g945 g942 g944 g943) + (if (memv g947 '(constant)) + (list 'quote + (g450 (g394 g945 g944 g943) '(()))) + (if (memv g947 '(global)) + g941 + (if (memv g947 '(call)) + (g434 (g432 (car g945) g942 g944) + g945 + g942 + g944 + g943) + (if (memv g947 '(begin-form)) + ((lambda (g948) + ((lambda (g949) + (if g949 + (apply + (lambda (g952 + g950 + g951) + (g395 (cons g950 + g951) + g942 + g944 + g943)) + g949) + (syntax-error + g948))) + ($syntax-dispatch + g948 + '(any any + . + each-any)))) + g945) + (if (memv g947 + '(local-syntax-form)) + (g445 g941 + g945 + g942 + g944 + g943 + g395) + (if (memv g947 + '(eval-when-form)) + ((lambda (g954) + ((lambda (g955) + (if g955 + (apply + (lambda (g959 + g956 + g958 + g957) + ((lambda (g960) + (if (memq 'eval + g960) + (g395 (cons g958 + g957) + g942 + g944 + g943) + (g446))) + (g397 g945 + g956 + g944))) + g955) + (syntax-error + g954))) + ($syntax-dispatch + g954 + '(any each-any + any + . + each-any)))) + g945) + (if (memv g947 + '(define-form + define-syntax-form + module-form + import-form)) + (syntax-error + (g394 g945 + g944 + g943) + '"invalid context for definition") + (if (memv g947 + '(syntax)) + (syntax-error + (g394 g945 + g944 + g943) + '"reference to pattern variable outside syntax form") + (if (memv g947 + '(displaced-lexical)) + (g250 (g394 g945 + g944 + g943)) + (syntax-error + (g394 g945 + g944 + g943))))))))))))))) + g946))) + (g432 + (lambda (g1612 g1610 g1611) + (call-with-values + (lambda () (g398 g1612 g1610 g1611 '#f '#f)) + (lambda (g1617 g1613 g1616 g1614 g1615) + (g433 g1617 g1613 g1616 g1610 g1614 g1615))))) + (g431 + (lambda (g965 g963 g964) + ((lambda (g966) + (if (memv g966 '(c)) + (if (memq 'compile g963) + ((lambda (g967) + (begin (g91 g967) + (if (memq 'load g963) g967 (g446)))) + (g964)) + (if (memq 'load g963) (g964) (g446))) + (if (memv g966 '(c&e)) + ((lambda (g968) (begin (g91 g968) g968)) (g964)) + (begin (if (memq 'eval g963) (g91 (g964)) (void)) + (g446))))) + g965))) + (g430 + (lambda (g1609 g1608) + (list '$sc-put-cte + (list 'quote g1609) + (list 'quote (g231 'do-import g1608))))) + (g429 + (lambda (g970 g969) + ((lambda (g971) + ((letrec ((g972 + (lambda (g973) + (if (not (= g973 g971)) + (begin (g970 (vector-ref g969 g973)) + (g972 (+ g973 '1))) + (void))))) + g972) + '0)) + (vector-length g969)))) + (g428 + (lambda (g1604 g1603) + ((letrec ((g1605 + (lambda (g1607 g1606) + (if (< g1607 '0) + g1606 + (g1605 + (- g1607 '1) + (cons (g1604 (vector-ref g1603 g1607)) + g1606)))))) + g1605) + (- (vector-length g1603) '1) + '()))) + (g427 + (lambda (g982 g974 g981 g975 g980 g976 g979 g977 g978) + (letrec ((g985 + (lambda (g1050 g1049) + ((lambda (g1051) + (map (lambda (g1052) + ((lambda (g1053) + (if (not (g392 g1053 g1051)) + g1052 + (g410 (g412 g1052) + g1053 + (g414 g1052) + (append + (g984 g1053) + (g415 g1052)) + (g416 g1052)))) + (g413 g1052))) + g1050)) + (map (lambda (g1054) + (if (pair? g1054) (car g1054) g1054)) + g1049)))) + (g984 + (lambda (g1043) + ((letrec ((g1044 + (lambda (g1045) + (if (null? g1045) + '() + (if (if (pair? (car g1045)) + (g388 g1043 + (caar g1045)) + '#f) + (g401 (cdar g1045)) + (g1044 (cdr g1045))))))) + g1044) + g980))) + (g983 + (lambda (g1048 g1046 g1047) + (begin (g426 g974 g1046) + (g425 g974 g976 g1046) + (g978 g1048 g1047))))) + ((letrec ((g986 + (lambda (g990 g987 g989 g988) + (if (null? g990) + (g983 g989 g987 g988) + ((lambda (g992 g991) + (call-with-values + (lambda () + (g398 g992 g991 '(()) '#f g982)) + (lambda (g997 g993 g996 g994 g995) + ((lambda (g998) + (if (memv g998 '(define-form)) + (g442 g996 + g994 + g995 + (lambda (g1001 + g999 + g1000) + ((lambda (g1002) + ((lambda (g1003) + ((lambda (g1004) + ((lambda () + (begin (g363 g982 + g1002 + g1003) + (g986 (cdr g990) + (cons g1002 + g987) + (cons (g410 g997 + g1002 + g1003 + g1004 + (cons g991 + (g393 g999 + g1000))) + g989) + g988))))) + (g984 g1002))) + (g300))) + (g393 g1001 + g1000)))) + (if (memv g998 + '(define-syntax-form)) + (g443 g996 + g994 + g995 + (lambda (g1007 + g1005 + g1006) + ((lambda (g1008) + ((lambda (g1009) + ((lambda (g1010) + ((lambda (g1011) + ((lambda () + (begin (g424 g975 + (g302 g1009) + (cons 'deferred + g1011)) + (g363 g982 + g1008 + g1009) + (g986 (cdr g990) + (cons g1008 + g987) + (cons (g410 g997 + g1008 + g1009 + g1010 + g1011) + g989) + g988))))) + (g432 g1005 + (g249 g991) + g1006))) + (g984 g1008))) + (g300))) + (g393 g1007 + g1006)))) + (if (memv g998 + '(module-form)) + ((lambda (g1012) + ((lambda (g1013) + ((lambda () + (g440 g996 + g994 + g995 + g1013 + (lambda (g1016 + g1014 + g1015) + (g427 g1012 + (g394 g996 + g994 + g995) + (map (lambda (g1024) + (cons g991 + g1024)) + g1015) + g975 + g1014 + (g401 g1014) + g979 + g977 + (lambda (g1018 + g1017) + ((lambda (g1019) + ((lambda (g1020) + ((lambda (g1021) + ((lambda () + (if g1016 + ((lambda (g1023 + g1022) + (begin (g424 g975 + (g302 g1023) + (g231 'module + g1019)) + (g363 g982 + g1016 + g1023) + (g986 (cdr g990) + (cons g1016 + g987) + (cons (g410 g997 + g1016 + g1023 + g1022 + g1014) + g1020) + g1021))) + (g300) + (g984 g1016)) + ((lambda () + (begin (g439 g1019 + g982) + (g986 (cdr g990) + (cons g1019 + g987) + g1020 + g1021)))))))) + (append + g988 + g1017))) + (append + (if g1016 + g1018 + (g985 g1018 + g1014)) + g989))) + (g408 g1014))))))))) + (g263 (g264 g994) + (cons g1012 + (g265 g994))))) + (g304 '() + '() + '())) + (if (memv g998 + '(import-form)) + (g441 g996 + g994 + g995 + (lambda (g1025) + ((lambda (g1026) + ((lambda (g1027) + ((lambda (g1028) + (if (memv g1028 + '(module)) + ((lambda (g1029) + (begin (if g993 + (g364 g982 + g993) + (void)) + (g439 g1029 + g982) + (g986 (cdr g990) + (cons g1029 + g987) + (g985 g989 + (vector->list + (g404 g1029))) + g988))) + (g233 g1027)) + (if (memv g1028 + '(displaced-lexical)) + (g250 g1025) + (syntax-error + g1025 + '"import from unknown module")))) + (g232 g1027))) + (g253 g1026 + g975))) + (g377 g1025 + '(()))))) + (if (memv g998 + '(begin-form)) + ((lambda (g1030) + ((lambda (g1031) + (if g1031 + (apply + (lambda (g1033 + g1032) + (g986 ((letrec ((g1034 + (lambda (g1035) + (if (null? + g1035) + (cdr g990) + (cons (cons g991 + (g393 (car g1035) + g994)) + (g1034 + (cdr g1035))))))) + g1034) + g1032) + g987 + g989 + g988)) + g1031) + (syntax-error + g1030))) + ($syntax-dispatch + g1030 + '(any . + each-any)))) + g996) + (if (memv g998 + '(local-syntax-form)) + (g445 g993 + g996 + g991 + g994 + g995 + (lambda (g1040 + g1037 + g1039 + g1038) + (g986 ((letrec ((g1041 + (lambda (g1042) + (if (null? + g1042) + (cdr g990) + (cons (cons g1037 + (g393 (car g1042) + g1039)) + (g1041 + (cdr g1042))))))) + g1041) + g1040) + g987 + g989 + g988))) + (g983 g989 + g987 + (append + g988 + (cons (cons g991 + (g394 g996 + g994 + g995)) + (cdr g990))))))))))) + g997)))) + (cdar g990) + (caar g990)))))) + g986) + g981 + '() + '() + '())))) + (g426 + (lambda (g1560 g1559) + (letrec ((g1564 + (lambda (g1597 g1595 g1596) + ((lambda (g1598) + (if g1598 + (if (g367 ((lambda (g1599) + ((lambda (g1600) + (if (g90 g1600) + (annotation-expression + g1600) + g1600)) + (if (g204 g1599) + (g205 g1599) + g1599))) + g1597) + g1598 + (if (symbol? g1597) + (g264 '((top))) + (g264 (g206 g1597)))) + (cons g1597 g1596) + g1596) + (g1562 + (g404 g1595) + (lambda (g1602 g1601) + (if (g1561 g1602 g1597) + (cons g1602 g1601) + g1601)) + g1596))) + (g405 g1595)))) + (g1563 + (lambda (g1575 g1573 g1574) + (if (g403 g1575) + (if (g403 g1573) + (call-with-values + (lambda () + ((lambda (g1581 g1580) + (if (fx> (vector-length g1581) + (vector-length g1580)) + (values g1575 g1580) + (values g1573 g1581))) + (g404 g1575) + (g404 g1573))) + (lambda (g1577 g1576) + (g1562 + g1576 + (lambda (g1579 g1578) + (g1564 g1579 g1577 g1578)) + g1574))) + (g1564 g1573 g1575 g1574)) + (if (g403 g1573) + (g1564 g1575 g1573 g1574) + (if (g1561 g1575 g1573) + (cons g1575 g1574) + g1574))))) + (g1562 + (lambda (g1590 g1588 g1589) + ((lambda (g1591) + ((letrec ((g1592 + (lambda (g1594 g1593) + (if (= g1594 g1591) + g1593 + (g1592 + (+ g1594 '1) + (g1588 + (vector-ref g1590 g1594) + g1593)))))) + g1592) + '0 + g1589)) + (vector-length g1590)))) + (g1561 + (lambda (g1583 g1582) + (if (symbol? g1583) + (if (symbol? g1582) + (eq? g1583 g1582) + (if (eq? g1583 + ((lambda (g1584) + ((lambda (g1585) + (if (g90 g1585) + (annotation-expression + g1585) + g1585)) + (if (g204 g1584) + (g205 g1584) + g1584))) + g1582)) + (g373 (g264 (g206 g1582)) + (g264 '((top)))) + '#f)) + (if (symbol? g1582) + (if (eq? g1582 + ((lambda (g1586) + ((lambda (g1587) + (if (g90 g1587) + (annotation-expression + g1587) + g1587)) + (if (g204 g1586) + (g205 g1586) + g1586))) + g1583)) + (g373 (g264 (g206 g1583)) + (g264 '((top)))) + '#f) + (g388 g1583 g1582)))))) + (if (not (null? g1559)) + ((letrec ((g1565 + (lambda (g1568 g1566 g1567) + (if (null? g1566) + (if (not (null? g1567)) + ((lambda (g1569) + (syntax-error + g1560 + '"duplicate definition for " + (symbol->string (car g1569)) + '" in")) + (syntax-object->datum g1567)) + (void)) + ((letrec ((g1570 + (lambda (g1572 g1571) + (if (null? g1572) + (g1565 + (car g1566) + (cdr g1566) + g1571) + (g1570 + (cdr g1572) + (g1563 + g1568 + (car g1572) + g1571)))))) + g1570) + g1566 + g1567))))) + g1565) + (car g1559) + (cdr g1559) + '()) + (void))))) + (g425 + (lambda (g1057 g1055 g1056) + (letrec ((g1058 + (lambda (g1065 g1064) + (ormap + (lambda (g1066) + (if (g403 g1066) + ((lambda (g1067) + (if g1067 + (g367 ((lambda (g1068) + ((lambda (g1069) + (if (g90 g1069) + (annotation-expression + g1069) + g1069)) + (if (g204 g1068) + (g205 g1068) + g1068))) + g1065) + g1067 + (g264 (g206 g1065))) + ((lambda (g1070) + ((letrec ((g1071 + (lambda (g1072) + (if (fx>= g1072 + '0) + ((lambda (g1073) + (if g1073 + g1073 + (g1071 + (- g1072 + '1)))) + (g388 g1065 + (vector-ref + g1070 + g1072))) + '#f)))) + g1071) + (- (vector-length g1070) + '1))) + (g404 g1066)))) + (g405 g1066)) + (g388 g1065 g1066))) + g1064)))) + ((letrec ((g1059 + (lambda (g1061 g1060) + (if (null? g1061) + (if (not (null? g1060)) + (syntax-error + g1060 + '"missing definition for export(s)") + (void)) + ((lambda (g1063 g1062) + (if (g1058 g1063 g1056) + (g1059 g1062 g1060) + (g1059 g1062 (cons g1063 g1060)))) + (car g1061) + (cdr g1061)))))) + g1059) + g1055 + '())))) + (g424 + (lambda (g1558 g1556 g1557) + (set-cdr! g1558 (g246 g1556 g1557 (cdr g1558))))) + (g423 + (lambda (g1075 g1074) + (if (null? g1075) + '() + (if (g392 (car g1075) g1074) + (g423 (cdr g1075) g1074) + (cons (car g1075) (g423 (cdr g1075) g1074)))))) + (g422 + (lambda (g1491 + g1482 + g1490 + g1483 + g1489 + g1484 + g1488 + g1485 + g1487 + g1486) + ((lambda (g1492) + (g427 g1490 + (g394 g1491 g1483 g1489) + (map (lambda (g1555) (cons g1482 g1555)) g1486) + g1482 + g1487 + g1492 + g1484 + g1488 + (lambda (g1494 g1493) + ((letrec ((g1495 + (lambda (g1500 + g1496 + g1499 + g1497 + g1498) + (if (null? g1500) + ((letrec ((g1501 + (lambda (g1504 + g1502 + g1503) + (if (null? g1504) + ((lambda (g1507 + g1505 + g1506) + (begin (for-each + (lambda (g1523) + (apply + (lambda (g1527 + g1524 + g1526 + g1525) + (if g1524 + (g303 g1524 + g1526) + (void))) + g1523)) + g1498) + (g190 '#f + (list (g431 g1484 + g1488 + (lambda () + (if (null? + g1498) + (g446) + (g190 '#f + (map (lambda (g1518) + (apply + (lambda (g1522 + g1519 + g1521 + g1520) + (list '$sc-put-cte + (list 'quote + g1521) + (if (eq? g1522 + 'define-syntax-form) + g1520 + (list 'quote + (g231 'module + (g409 g1520 + g1521)))))) + g1518)) + g1498))))) + (g431 g1484 + g1488 + (lambda () + ((lambda (g1508) + ((lambda (g1509) + ((lambda (g1510) + ((lambda () + (if g1508 + (list '$sc-put-cte + (list 'quote + (if (g373 (g264 (g206 g1485)) + (g264 '((top)))) + g1508 + ((lambda (g1511) + (g203 g1508 + (g263 g1511 + (list (g304 (vector + g1508) + (vector + g1511) + (vector + (g101 g1508))))))) + (g264 (g206 g1485))))) + g1510) + ((lambda (g1512) + (g190 '#f + (list (list '$sc-put-cte + (list 'quote + g1512) + g1510) + (g430 g1512 + g1509)))) + (g101 'tmp)))))) + (list 'quote + (g231 'module + (g409 g1487 + g1509))))) + (g101 g1508))) + (if g1485 + ((lambda (g1513) + ((lambda (g1514) + (if (g90 g1514) + (annotation-expression + g1514) + g1514)) + (if (g204 g1513) + (g205 g1513) + g1513))) + g1485) + '#f)))) + (g190 '#f + (map (lambda (g1517) + (list 'define + g1517 + (g446))) + g1499)) + (g191 '#f + g1502 + g1505 + (g190 '#f + (list (if (null? + g1499) + (g446) + (g190 '#f + (map (lambda (g1516 + g1515) + (list 'set! + g1516 + g1515)) + g1499 + g1507))) + (if (null? + g1506) + (g446) + (g190 '#f + g1506))))) + (g446))))) + (map (lambda (g1530) + (g432 (cdr g1530) + (car g1530) + '(()))) + g1497) + (map (lambda (g1528) + (g432 (cdr g1528) + (car g1528) + '(()))) + g1503) + (map (lambda (g1529) + (g432 (cdr g1529) + (car g1529) + '(()))) + g1493)) + ((lambda (g1531) + ((lambda (g1532) + (if (memv g1532 + '(define-form)) + ((lambda (g1533) + (begin (g424 g1482 + (g302 (g414 g1531)) + (g231 'lexical + g1533)) + (g1501 + (cdr g1504) + (cons g1533 + g1502) + (cons (g416 g1531) + g1503)))) + (g451 (g413 g1531))) + (if (memv g1532 + '(define-syntax-form + module-form)) + (g1501 + (cdr g1504) + g1502 + g1503) + (error 'sc-expand-internal + '"unexpected module binding type")))) + (g412 g1531))) + (car g1504)))))) + g1501) + g1496 + '() + '()) + ((lambda (g1535 g1534) + (letrec ((g1536 + (lambda (g1551 + g1548 + g1550 + g1549) + ((letrec ((g1552 + (lambda (g1554 + g1553) + (if (null? + g1554) + (g1549) + (if (g388 (g413 (car g1554)) + g1551) + (g1550 + (car g1554) + (g370 (reverse + g1553) + (cdr g1554))) + (g1552 + (cdr g1554) + (cons (car g1554) + g1553))))))) + g1552) + g1548 + '())))) + (g1536 + g1535 + g1496 + (lambda (g1538 g1537) + ((lambda (g1541 + g1539 + g1540) + ((lambda (g1543 + g1542) + ((lambda (g1544) + (if (memv g1544 + '(define-form)) + (begin (g303 g1539 + g1542) + (g1495 + g1543 + g1537 + (cons g1542 + g1499) + (cons (g416 g1538) + g1497) + g1498)) + (if (memv g1544 + '(define-syntax-form)) + (g1495 + g1543 + g1537 + g1499 + g1497 + (cons (list g1541 + g1539 + g1542 + (g416 g1538)) + g1498)) + (if (memv g1544 + '(module-form)) + ((lambda (g1545) + (g1495 + (append + (g401 g1545) + g1543) + g1537 + g1499 + g1497 + (cons (list g1541 + g1539 + g1542 + g1545) + g1498))) + (g416 g1538)) + (error 'sc-expand-internal + '"unexpected module binding type"))))) + g1541)) + (append + g1540 + g1534) + (g101 ((lambda (g1546) + ((lambda (g1547) + (if (g90 g1547) + (annotation-expression + g1547) + g1547)) + (if (g204 g1546) + (g205 g1546) + g1546))) + g1535)))) + (g412 g1538) + (g414 g1538) + (g415 g1538))) + (lambda () + (g1495 + g1534 + g1496 + g1499 + g1497 + g1498))))) + (car g1500) + (cdr g1500)))))) + g1495) + g1492 + g1494 + '() + '() + '())))) + (g401 g1487)))) + (g421 (lambda (g1077 g1076) (vector-set! g1077 '5 g1076))) + (g420 (lambda (g1481 g1480) (vector-set! g1481 '4 g1480))) + (g419 (lambda (g1079 g1078) (vector-set! g1079 '3 g1078))) + (g418 (lambda (g1479 g1478) (vector-set! g1479 '2 g1478))) + (g417 (lambda (g1081 g1080) (vector-set! g1081 '1 g1080))) + (g416 (lambda (g1477) (vector-ref g1477 '5))) + (g415 (lambda (g1082) (vector-ref g1082 '4))) + (g414 (lambda (g1476) (vector-ref g1476 '3))) + (g413 (lambda (g1083) (vector-ref g1083 '2))) + (g412 (lambda (g1475) (vector-ref g1475 '1))) + (g411 + (lambda (g1084) + (if (vector? g1084) + (if (= (vector-length g1084) '6) + (eq? (vector-ref g1084 '0) 'module-binding) + '#f) + '#f))) + (g410 + (lambda (g1474 g1470 g1473 g1471 g1472) + (vector 'module-binding g1474 g1470 g1473 g1471 g1472))) + (g409 + (lambda (g1086 g1085) + (g402 (list->vector + (map (lambda (g1087) + (g369 (if (pair? g1087) (car g1087) g1087))) + g1086)) + g1085))) + (g408 + (lambda (g1468) + (g402 (list->vector + (map (lambda (g1469) + (if (pair? g1469) (car g1469) g1469)) + g1468)) + '#f))) + (g407 (lambda (g1089 g1088) (vector-set! g1089 '2 g1088))) + (g406 (lambda (g1467 g1466) (vector-set! g1467 '1 g1466))) + (g405 (lambda (g1090) (vector-ref g1090 '2))) + (g404 (lambda (g1465) (vector-ref g1465 '1))) + (g403 + (lambda (g1091) + (if (vector? g1091) + (if (= (vector-length g1091) '3) + (eq? (vector-ref g1091 '0) 'interface) + '#f) + '#f))) + (g402 + (lambda (g1464 g1463) (vector 'interface g1464 g1463))) + (g401 + (lambda (g1092) + ((letrec ((g1093 + (lambda (g1095 g1094) + (if (null? g1095) + g1094 + (g1093 + (cdr g1095) + (if (pair? (car g1095)) + (g1093 (car g1095) g1094) + (cons (car g1095) g1094))))))) + g1093) + g1092 + '()))) + (g400 + (lambda (g1390 g1385 g1389 g1386 g1388 g1387) + (call-with-values + (lambda () (g398 g1390 g1385 g1389 '#f g1387)) + (lambda (g1401 g1397 g1400 g1398 g1399) + ((lambda (g1402) + (if (memv g1402 '(begin-form)) + ((lambda (g1403) + ((lambda (g1404) + (if g1404 + (apply (lambda (g1405) (g446)) g1404) + ((lambda (g1406) + (if g1406 + (apply + (lambda (g1409 g1407 g1408) + (g396 (cons g1407 g1408) + g1385 + g1398 + g1399 + g1386 + g1388 + g1387)) + g1406) + (syntax-error g1403))) + ($syntax-dispatch + g1403 + '(any any . each-any))))) + ($syntax-dispatch g1403 '(any)))) + g1400) + (if (memv g1402 '(local-syntax-form)) + (g445 g1397 + g1400 + g1385 + g1398 + g1399 + (lambda (g1414 g1411 g1413 g1412) + (g396 g1414 + g1411 + g1413 + g1412 + g1386 + g1388 + g1387))) + (if (memv g1402 '(eval-when-form)) + ((lambda (g1415) + ((lambda (g1416) + (if g1416 + (apply + (lambda (g1420 + g1417 + g1419 + g1418) + ((lambda (g1422 g1421) + (if (eq? g1386 'e) + (if (memq 'eval + g1422) + (g396 g1421 + g1385 + g1398 + g1399 + 'e + '(eval) + g1387) + (g446)) + (if (memq 'load + g1422) + (if ((lambda (g1423) + (if g1423 + g1423 + (if (eq? g1386 + 'c&e) + (memq 'eval + g1422) + '#f))) + (memq 'compile + g1422)) + (g396 g1421 + g1385 + g1398 + g1399 + 'c&e + '(compile + load) + g1387) + (if (memq g1386 + '(c c&e)) + (g396 g1421 + g1385 + g1398 + g1399 + 'c + '(load) + g1387) + (g446))) + (if ((lambda (g1424) + (if g1424 + g1424 + (if (eq? g1386 + 'c&e) + (memq 'eval + g1422) + '#f))) + (memq 'compile + g1422)) + (begin (g91 (g396 g1421 + g1385 + g1398 + g1399 + 'e + '(eval) + g1387)) + (g446)) + (g446))))) + (g397 g1400 g1417 g1398) + (cons g1419 g1418))) + g1416) + (syntax-error g1415))) + ($syntax-dispatch + g1415 + '(any each-any any . each-any)))) + g1400) + (if (memv g1402 '(define-syntax-form)) + (g443 g1400 + g1398 + g1399 + (lambda (g1429 g1427 g1428) + ((lambda (g1430) + (begin ((lambda (g1435) + ((lambda (g1436) + ((lambda (g1437) + (if (memv g1437 + '(displaced-lexical)) + (g250 g1430) + (void))) + (g232 g1436))) + (g253 g1435 + g1385))) + (g377 g1430 + '(()))) + (g431 g1386 + g1388 + (lambda () + (list '$sc-put-cte + (list 'quote + ((lambda (g1431) + (if (g373 (g264 (g206 g1430)) + (g264 '((top)))) + g1431 + ((lambda (g1432) + (g203 g1431 + (g263 g1432 + (list (g304 (vector + g1431) + (vector + g1432) + (vector + (g101 g1431))))))) + (g264 (g206 g1430))))) + ((lambda (g1433) + ((lambda (g1434) + (if (g90 g1434) + (annotation-expression + g1434) + g1434)) + (if (g204 g1433) + (g205 g1433) + g1433))) + g1430))) + (g432 g1427 + (g249 g1385) + g1428)))))) + (g393 g1429 g1428)))) + (if (memv g1402 '(define-form)) + (g442 g1400 + g1398 + g1399 + (lambda (g1440 g1438 g1439) + ((lambda (g1441) + (begin ((lambda (g1448) + ((lambda (g1449) + ((lambda (g1450) + (if (memv g1450 + '(displaced-lexical)) + (g250 g1441) + (void))) + (g232 g1449))) + (g253 g1448 + g1385))) + (g377 g1441 + '(()))) + ((lambda (g1442) + ((lambda (g1443) + (g190 '#f + (list (g431 g1386 + g1388 + (lambda () + (list '$sc-put-cte + (list 'quote + (if (eq? g1442 + g1443) + g1442 + ((lambda (g1445) + (g203 g1442 + (g263 g1445 + (list (g304 (vector + g1442) + (vector + g1445) + (vector + g1443)))))) + (g264 (g206 g1441))))) + (list 'quote + (g231 'global + g1443))))) + ((lambda (g1444) + (begin (if (eq? g1386 + 'c&e) + (g91 g1444) + (void)) + g1444)) + (list 'define + g1443 + (g432 g1438 + g1385 + g1439)))))) + (if (g373 (g264 (g206 g1441)) + (g264 '((top)))) + g1442 + (g101 g1442)))) + ((lambda (g1446) + ((lambda (g1447) + (if (g90 g1447) + (annotation-expression + g1447) + g1447)) + (if (g204 g1446) + (g205 g1446) + g1446))) + g1441)))) + (g393 g1440 g1439)))) + (if (memv g1402 '(module-form)) + ((lambda (g1452 g1451) + (g440 g1400 + g1398 + g1399 + (g263 (g264 g1398) + (cons g1451 + (g265 g1398))) + (lambda (g1455 + g1453 + g1454) + (if g1455 + (begin ((lambda (g1456) + ((lambda (g1457) + ((lambda (g1458) + (if (memv g1458 + '(displaced-lexical)) + (g250 (g393 g1455 + g1398)) + (void))) + (g232 g1457))) + (g253 g1456 + g1452))) + (g377 g1455 + '(()))) + (g422 g1400 + g1452 + g1451 + g1398 + g1399 + g1386 + g1388 + g1455 + g1453 + g1454)) + (g422 g1400 + g1452 + g1451 + g1398 + g1399 + g1386 + g1388 + '#f + g1453 + g1454))))) + (cons '("top-level module placeholder" + placeholder) + g1385) + (g304 '() '() '())) + (if (memv g1402 + '(import-form)) + (g441 g1400 + g1398 + g1399 + (lambda (g1459) + (g431 g1386 + g1388 + (lambda () + (begin (if g1397 + (syntax-error + (g394 g1400 + g1398 + g1399) + '"not valid at top-level") + (void)) + ((lambda (g1460) + ((lambda (g1461) + (if (memv g1461 + '(module)) + (g430 g1459 + (g405 (g233 g1460))) + (if (memv g1461 + '(displaced-lexical)) + (g250 g1459) + (syntax-error + g1459 + '"import from unknown module")))) + (g232 g1460))) + (g253 (g377 g1459 + '(())) + '()))))))) + ((lambda (g1462) + (begin (if (eq? g1386 + 'c&e) + (g91 g1462) + (void)) + g1462)) + (g433 g1401 + g1397 + g1400 + g1385 + g1398 + g1399)))))))))) + g1401))))) + (g399 + (lambda (g1099 g1096 g1098 g1097) + (call-with-values + (lambda () (g398 g1099 g1096 g1098 '#f g1097)) + (lambda (g1104 g1100 g1103 g1101 g1102) + (g433 g1104 g1100 g1103 g1096 g1101 g1102))))) + (g398 + (lambda (g1370 g1366 g1369 g1367 g1368) + (if (symbol? g1370) + ((lambda (g1371) + ((lambda (g1372) + ((lambda (g1373) + ((lambda () + ((lambda (g1374) + (if (memv g1374 '(lexical)) + (values + g1373 + (g233 g1372) + g1370 + g1369 + g1367) + (if (memv g1374 '(global)) + (values + g1373 + (g233 g1372) + g1370 + g1369 + g1367) + (if (memv g1374 '(macro macro!)) + (g398 (g436 (g233 g1372) + g1370 + g1366 + g1369 + g1367 + g1368) + g1366 + '(()) + '#f + g1368) + (values + g1373 + (g233 g1372) + g1370 + g1369 + g1367))))) + g1373)))) + (g232 g1372))) + (g253 g1371 g1366))) + (g377 g1370 g1369)) + (if (pair? g1370) + ((lambda (g1375) + (if (g256 g1375) + ((lambda (g1376) + ((lambda (g1377) + ((lambda (g1378) + ((lambda () + ((lambda (g1379) + (if (memv g1379 '(lexical)) + (values + 'lexical-call + (g233 g1377) + g1370 + g1369 + g1367) + (if (memv g1379 + '(macro macro!)) + (g398 (g436 (g233 g1377) + g1370 + g1366 + g1369 + g1367 + g1368) + g1366 + '(()) + '#f + g1368) + (if (memv g1379 + '(core)) + (values + g1378 + (g233 g1377) + g1370 + g1369 + g1367) + (if (memv g1379 + '(local-syntax)) + (values + 'local-syntax-form + (g233 g1377) + g1370 + g1369 + g1367) + (if (memv g1379 + '(begin)) + (values + 'begin-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(eval-when)) + (values + 'eval-when-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(define)) + (values + 'define-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(define-syntax)) + (values + 'define-syntax-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(module-key)) + (values + 'module-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(import)) + (values + 'import-form + (if (g233 g1377) + (g393 g1375 + g1369) + '#f) + g1370 + g1369 + g1367) + (if (memv g1379 + '(set!)) + (g435 g1370 + g1366 + g1369 + g1367 + g1368) + (values + 'call + '#f + g1370 + g1369 + g1367))))))))))))) + g1378)))) + (g232 g1377))) + (g253 g1376 g1366))) + (g377 g1375 g1369)) + (values 'call '#f g1370 g1369 g1367))) + (car g1370)) + (if (g204 g1370) + (g398 (g205 g1370) + g1366 + (g371 g1369 (g206 g1370)) + '#f + g1368) + (if (g90 g1370) + (g398 (annotation-expression g1370) + g1366 + g1369 + (annotation-source g1370) + g1368) + (if ((lambda (g1380) + ((lambda (g1381) + (if g1381 + g1381 + ((lambda (g1382) + (if g1382 + g1382 + ((lambda (g1383) + (if g1383 + g1383 + ((lambda (g1384) + (if g1384 + g1384 + (null? + g1380))) + (char? + g1380)))) + (string? g1380)))) + (number? g1380)))) + (boolean? g1380))) + g1370) + (values 'constant '#f g1370 g1369 g1367) + (values + 'other + '#f + g1370 + g1369 + g1367)))))))) + (g397 + (lambda (g1107 g1105 g1106) + ((letrec ((g1108 + (lambda (g1110 g1109) + (if (null? g1110) + g1109 + (g1108 + (cdr g1110) + (cons ((lambda (g1111) + (if (g378 g1111 + '#(syntax-object + compile + ((top) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(when-list + situations) + #((top) (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e when-list w) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + 'compile + (if (g378 g1111 + '#(syntax-object + load + ((top) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(when-list + situations) + #((top) + (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + when-list + w) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + 'load + (if (g378 g1111 + '#(syntax-object + eval + ((top) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(when-list + situations) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + when-list + w) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + 'eval + (syntax-error + (g393 g1111 g1106) + '"invalid eval-when situation"))))) + (car g1110)) + g1109)))))) + g1108) + g1105 + '()))) + (g396 + (lambda (g1358 g1352 g1357 g1353 g1356 g1354 g1355) + (g190 g1353 + ((letrec ((g1359 + (lambda (g1364 g1360 g1363 g1361 g1362) + (if (null? g1364) + '() + ((lambda (g1365) + (cons g1365 + (g1359 + (cdr g1364) + g1360 + g1363 + g1361 + g1362))) + (g400 (car g1364) + g1360 + g1363 + g1361 + g1362 + g1355)))))) + g1359) + g1358 + g1352 + g1357 + g1356 + g1354)))) + (g395 + (lambda (g1115 g1112 g1114 g1113) + (g190 g1113 + ((letrec ((g1116 + (lambda (g1119 g1117 g1118) + (if (null? g1119) + '() + ((lambda (g1120) + (cons g1120 + (g1116 + (cdr g1119) + g1117 + g1118))) + (g432 (car g1119) g1117 g1118)))))) + g1116) + g1115 + g1112 + g1114)))) + (g394 + (lambda (g1351 g1349 g1350) + (g393 (if g1350 (make-annotation g1351 g1350 '#f) g1351) + g1349))) + (g393 + (lambda (g1122 g1121) + (if (if (null? (g264 g1121)) (null? (g265 g1121)) '#f) + g1122 + (if (g204 g1122) + (g203 (g205 g1122) (g371 g1121 (g206 g1122))) + (if (null? g1122) g1122 (g203 g1122 g1121)))))) + (g392 + (lambda (g1347 g1346) + (if (not (null? g1346)) + ((lambda (g1348) + (if g1348 g1348 (g392 g1347 (cdr g1346)))) + (g388 g1347 (car g1346))) + '#f))) + (g391 + (lambda (g1125 g1123 g1124) + ((letrec ((g1126 + (lambda (g1128 g1127) + (if (null? g1128) + (syntax-error g1123) + (if (g256 (car g1128)) + (if (g392 (car g1128) g1127) + (syntax-error + (car g1128) + '"duplicate " + g1124) + (g1126 + (cdr g1128) + (cons (car g1128) g1127))) + (syntax-error + (car g1128) + '"invalid " + g1124)))))) + g1126) + g1125 + '()))) + (g390 + (lambda (g1342) + ((letrec ((g1343 + (lambda (g1344) + ((lambda (g1345) + (if g1345 + g1345 + (if (not (g392 (car g1344) (cdr g1344))) + (g1343 (cdr g1344)) + '#f))) + (null? g1344))))) + g1343) + g1342))) + (g389 + (lambda (g1129) + (if ((letrec ((g1130 + (lambda (g1131) + ((lambda (g1132) + (if g1132 + g1132 + (if (g256 (car g1131)) + (g1130 (cdr g1131)) + '#f))) + (null? g1131))))) + g1130) + g1129) + (g390 g1129) + '#f))) + (g388 + (lambda (g1337 g1336) + (if (if (g204 g1337) (g204 g1336) '#f) + (if (eq? ((lambda (g1339) + (if (g90 g1339) + (annotation-expression g1339) + g1339)) + (g205 g1337)) + ((lambda (g1338) + (if (g90 g1338) + (annotation-expression g1338) + g1338)) + (g205 g1336))) + (g373 (g264 (g206 g1337)) (g264 (g206 g1336))) + '#f) + (eq? ((lambda (g1341) + (if (g90 g1341) + (annotation-expression g1341) + g1341)) + g1337) + ((lambda (g1340) + (if (g90 g1340) + (annotation-expression g1340) + g1340)) + g1336))))) + (g378 + (lambda (g1134 g1133) + (if (eq? ((lambda (g1137) + ((lambda (g1138) + (if (g90 g1138) + (annotation-expression g1138) + g1138)) + (if (g204 g1137) (g205 g1137) g1137))) + g1134) + ((lambda (g1135) + ((lambda (g1136) + (if (g90 g1136) + (annotation-expression g1136) + g1136)) + (if (g204 g1135) (g205 g1135) g1135))) + g1133)) + (eq? (g377 g1134 '(())) (g377 g1133 '(()))) + '#f))) + (g377 + (lambda (g1333 g1332) + (call-with-values + (lambda () (g374 g1333 g1332)) + (lambda (g1335 g1334) + (if (g301 g1335) (g302 g1335) g1335))))) + (g376 + (lambda (g1140 g1139) + (call-with-values + (lambda () (g374 g1140 g1139)) + (lambda (g1142 g1141) g1142)))) + (g375 + (lambda (g1329 g1328) + (call-with-values + (lambda () (g374 g1329 g1328)) + (lambda (g1331 g1330) + (values (if (g301 g1331) (g302 g1331) g1331) g1330))))) + (g374 + (lambda (g1144 g1143) + (letrec ((g1147 + (lambda (g1174 g1170 g1173 g1171 g1172) + ((lambda (g1175) + ((letrec ((g1176 + (lambda (g1177) + (if (= g1177 g1175) + (g1145 + g1174 + (cdr g1170) + g1173) + (if (if (eq? (vector-ref + g1171 + g1177) + g1174) + (g373 g1173 + (vector-ref + (g307 g1172) + g1177)) + '#f) + (values + (vector-ref + (g308 g1172) + g1177) + g1173) + (g1176 (+ g1177 '1))))))) + g1176) + '0)) + (vector-length g1171)))) + (g1146 + (lambda (g1159 g1155 g1158 g1156 g1157) + ((letrec ((g1160 + (lambda (g1162 g1161) + (if (null? g1162) + (g1145 g1159 (cdr g1155) g1158) + (if (if (eq? (car g1162) g1159) + (g373 g1158 + (list-ref + (g307 g1157) + g1161)) + '#f) + (values + (list-ref + (g308 g1157) + g1161) + g1158) + (if (g357 (car g1162)) + ((lambda (g1163) + (if g1163 + ((lambda (g1164) + (if (symbol? + g1164) + (values + g1164 + g1158) + (g375 g1164 + '(())))) + g1163) + (g1160 + (cdr g1162) + g1161))) + (g367 g1159 + (g358 (car g1162)) + g1158)) + (if (if (eq? (car g1162) + g354) + (g373 g1158 + (list-ref + (g307 g1157) + g1161)) + '#f) + (values '#f g1158) + (g1160 + (cdr g1162) + (+ g1161 + '1))))))))) + g1160) + g1156 + '0))) + (g1145 + (lambda (g1167 g1165 g1166) + (if (null? g1165) + (values g1167 g1166) + ((lambda (g1168) + (if (eq? g1168 'shift) + (g1145 g1167 (cdr g1165) (cdr g1166)) + ((lambda (g1169) + (if (vector? g1169) + (g1147 + g1167 + g1165 + g1166 + g1169 + g1168) + (g1146 + g1167 + g1165 + g1166 + g1169 + g1168))) + (g306 g1168)))) + (car g1165)))))) + (if (symbol? g1144) + (g1145 g1144 (g265 g1143) (g264 g1143)) + (if (g204 g1144) + ((lambda (g1149 g1148) + ((lambda (g1150) + (call-with-values + (lambda () + (g1145 g1149 (g265 g1143) g1150)) + (lambda (g1152 g1151) + (if (eq? g1152 g1149) + (g1145 g1149 (g265 g1148) g1151) + (values g1152 g1151))))) + (g372 (g264 g1143) (g264 g1148)))) + ((lambda (g1153) + (if (g90 g1153) + (annotation-expression g1153) + g1153)) + (g205 g1144)) + (g206 g1144)) + (if (g90 g1144) + (g1145 + ((lambda (g1154) + (if (g90 g1154) + (annotation-expression g1154) + g1154)) + g1144) + (g265 g1143) + (g264 g1143)) + (g93 'id-var-name '"invalid id" g1144))))))) + (g373 + (lambda (g1326 g1325) + ((lambda (g1327) + (if g1327 + g1327 + (if (not (null? g1326)) + (if (not (null? g1325)) + (if (eq? (car g1326) (car g1325)) + (g373 (cdr g1326) (cdr g1325)) + '#f) + '#f) + '#f))) + (eq? g1326 g1325)))) + (g372 (lambda (g1179 g1178) (g370 g1179 g1178))) + (g371 + (lambda (g1322 g1321) + ((lambda (g1324 g1323) + (if (null? g1324) + (if (null? g1323) + g1321 + (g263 (g264 g1321) (g370 g1323 (g265 g1321)))) + (g263 (g370 g1324 (g264 g1321)) + (g370 g1323 (g265 g1321))))) + (g264 g1322) + (g265 g1322)))) + (g370 + (lambda (g1181 g1180) + (if (null? g1180) g1181 (append g1181 g1180)))) + (g369 + (lambda (g1315) + (call-with-values + (lambda () (g375 g1315 '(()))) + (lambda (g1317 g1316) + (begin (if (not g1317) + (syntax-error + g1315 + '"identifier not visible for export") + (void)) + ((lambda (g1318) + (g203 g1318 + (g263 g1316 + (list (g304 (vector g1318) + (vector g1316) + (vector g1317)))))) + ((lambda (g1319) + ((lambda (g1320) + (if (g90 g1320) + (annotation-expression g1320) + g1320)) + (if (g204 g1319) (g205 g1319) g1319))) + g1315))))))) + (g368 + (lambda (g1184 g1182 g1183) + (if (null? g1184) + g1183 + (g263 (g264 g1183) + (cons ((lambda (g1185) + ((lambda (g1186) + ((lambda (g1188 g1187) + (begin ((letrec ((g1189 + (lambda (g1191 + g1190) + (if (not (null? + g1191)) + (call-with-values + (lambda () + (g262 (car g1191) + g1183)) + (lambda (g1193 + g1192) + (begin (vector-set! + g1188 + g1190 + g1193) + (vector-set! + g1187 + g1190 + g1192) + (g1189 + (cdr g1191) + (+ g1190 + '1))))) + (void))))) + g1189) + g1184 + '0) + (g304 g1188 g1187 g1185))) + (make-vector g1186) + (make-vector g1186))) + (vector-length g1185))) + (list->vector g1182)) + (g265 g1183)))))) + (g367 + (lambda (g1310 g1308 g1309) + ((lambda (g1311) + (if g1311 + ((letrec ((g1312 + (lambda (g1313) + (if (pair? g1313) + ((lambda (g1314) + (if g1314 + g1314 + (g1312 (cdr g1313)))) + (g1312 (car g1313))) + (if (g373 g1309 (g264 (g206 g1313))) + g1313 + '#f))))) + g1312) + g1311) + '#f)) + (g100 g1310 g1308)))) + (g366 + (lambda (g1195 g1194) + (g309 g1195 (cons (g356 g1194) (g306 g1195))))) + (g365 + (lambda (g1307 g1306) + (begin (g309 g1307 (cons g354 (g306 g1307))) + (g310 g1307 (cons (g264 g1306) (g307 g1307)))))) + (g364 (lambda (g1197 g1196) (g365 g1197 (g206 g1196)))) + (g363 + (lambda (g1304 g1302 g1303) + (begin (g309 g1304 + (cons ((lambda (g1305) + (if (g90 g1305) + (annotation-expression g1305) + g1305)) + (g205 g1302)) + (g306 g1304))) + (g310 g1304 (cons (g264 (g206 g1302)) (g307 g1304))) + (g311 g1304 (cons g1303 (g308 g1304)))))) + (g358 cdr) + (g357 + (lambda (g1301) + (if (pair? g1301) (eq? (car g1301) g355) '#f))) + (g356 (lambda (g1198) (cons g355 g1198))) + (g355 'import-token) + (g354 '#f) + (g349 + (lambda (g1300) + (g263 (cons '#f (g264 g1300)) (cons 'shift (g265 g1300))))) + (g311 (lambda (g1200 g1199) (vector-set! g1200 '3 g1199))) + (g310 (lambda (g1299 g1298) (vector-set! g1299 '2 g1298))) + (g309 (lambda (g1202 g1201) (vector-set! g1202 '1 g1201))) + (g308 (lambda (g1297) (vector-ref g1297 '3))) + (g307 (lambda (g1203) (vector-ref g1203 '2))) + (g306 (lambda (g1296) (vector-ref g1296 '1))) + (g305 + (lambda (g1204) + (if (vector? g1204) + (if (= (vector-length g1204) '4) + (eq? (vector-ref g1204 '0) 'ribcage) + '#f) + '#f))) + (g304 + (lambda (g1295 g1293 g1294) + (vector 'ribcage g1295 g1293 g1294))) + (g303 set-car!) + (g302 car) + (g301 pair?) + (g300 (lambda () (list (g297)))) + (g299 + (lambda (g1205) + (if (null? g1205) '() (cons (g297) (g299 (cdr g1205)))))) + (g298 + (lambda (g1290) + ((lambda (g1291) + (if g1291 + g1291 + ((lambda (g1292) (if g1292 g1292 (g301 g1290))) + (symbol? g1290)))) + (string? g1290)))) + (g297 (lambda () (string '#\i))) + (g265 cdr) + (g264 car) + (g263 cons) + (g262 + (lambda (g1207 g1206) + (if (g204 g1207) + (values + ((lambda (g1208) + (if (g90 g1208) + (annotation-expression g1208) + g1208)) + (g205 g1207)) + (g372 (g264 g1206) (g264 (g206 g1207)))) + (values + ((lambda (g1209) + (if (g90 g1209) + (annotation-expression g1209) + g1209)) + g1207) + (g264 g1206))))) + (g256 + (lambda (g1288) + (if (symbol? g1288) + '#t + (if (g204 g1288) + (symbol? + ((lambda (g1289) + (if (g90 g1289) + (annotation-expression g1289) + g1289)) + (g205 g1288))) + (if (g90 g1288) + (symbol? (annotation-expression g1288)) + '#f))))) + (g255 + (lambda (g1210) + (if (g204 g1210) + (symbol? + ((lambda (g1211) + (if (g90 g1211) + (annotation-expression g1211) + g1211)) + (g205 g1210))) + '#f))) + (g254 + (lambda (g1287 g1285 g1286) (g98 g1285 (g231 g1287 g1286)))) + (g253 + (lambda (g1213 g1212) + (letrec ((g1214 + (lambda (g1221 g1220) + (begin (g234 g1221 (g232 g1220)) + (g235 g1221 (g233 g1220)))))) + ((lambda (g1215) + ((lambda (g1216) + (if (memv g1216 '(deferred)) + (begin (g1214 + g1215 + ((lambda (g1217) + ((lambda (g1218) + (if g1218 + g1218 + (syntax-error + g1217 + '"invalid transformer"))) + (g252 g1217))) + (g92 (g233 g1215)))) + ((lambda (g1219) g1215) (g232 g1215))) + g1215)) + (g232 g1215))) + (g251 g1213 g1212))))) + (g252 + (lambda (g1283) + (if (procedure? g1283) + (g231 'macro g1283) + (if (g236 g1283) + ((lambda (g1284) + (if (memv g1284 '(core macro macro!)) + (if (procedure? (g233 g1283)) g1283 '#f) + (if (memv g1284 '(module)) + (if (g403 (g233 g1283)) g1283 '#f) + g1283))) + (g232 g1283)) + '#f)))) + (g251 + (lambda (g1223 g1222) + ((lambda (g1224) + (if g1224 + (cdr g1224) + (if (symbol? g1223) + ((lambda (g1225) + (if g1225 g1225 (g231 'global g1223))) + (g99 g1223)) + (g231 'displaced-lexical '#f)))) + (assq g1223 g1222)))) + (g250 + (lambda (g1282) + (syntax-error + g1282 + (if (g377 g1282 '(())) + '"identifier out of context" + '"identifier not visible")))) + (g249 + (lambda (g1226) + (if (null? g1226) + '() + ((lambda (g1227) + (if (eq? (cadr g1227) 'lexical) + (g249 (cdr g1226)) + (cons g1227 (g249 (cdr g1226))))) + (car g1226))))) + (g248 + (lambda (g1281 g1279 g1280) + (if (null? g1281) + g1280 + (g248 (cdr g1281) + (cdr g1279) + (g246 (car g1281) + (g231 'lexical (car g1279)) + g1280))))) + (g247 + (lambda (g1230 g1228 g1229) + (if (null? g1230) + g1229 + (g247 (cdr g1230) + (cdr g1228) + (g246 (car g1230) (car g1228) g1229))))) + (g246 + (lambda (g1278 g1276 g1277) + (cons (cons g1278 g1276) g1277))) + (g236 + (lambda (g1231) + (if (pair? g1231) (symbol? (car g1231)) '#f))) + (g235 set-cdr!) + (g234 set-car!) + (g233 cdr) + (g232 car) + (g231 (lambda (g1275 g1274) (cons g1275 g1274))) + (g223 + (lambda (g1232) + (if (g90 g1232) + (annotation-source g1232) + (if (g204 g1232) (g223 (g205 g1232)) '#f)))) + (g208 (lambda (g1273 g1272) (vector-set! g1273 '2 g1272))) + (g207 (lambda (g1234 g1233) (vector-set! g1234 '1 g1233))) + (g206 (lambda (g1271) (vector-ref g1271 '2))) + (g205 (lambda (g1235) (vector-ref g1235 '1))) + (g204 + (lambda (g1270) + (if (vector? g1270) + (if (= (vector-length g1270) '3) + (eq? (vector-ref g1270 '0) 'syntax-object) + '#f) + '#f))) + (g203 + (lambda (g1237 g1236) (vector 'syntax-object g1237 g1236))) + (g191 + (lambda (g1269 g1266 g1268 g1267) + (if (null? g1266) + g1267 + (list 'letrec (map list g1266 g1268) g1267)))) + (g190 + (lambda (g1239 g1238) + (if (null? (cdr g1238)) (car g1238) (cons 'begin g1238)))) + (g101 + ((lambda (g1251) + (letrec ((g1254 + (lambda (g1260) + ((letrec ((g1261 + (lambda (g1263 g1262) + (if (< g1263 g1251) + (list->string + (cons (g1253 g1263) g1262)) + ((lambda (g1265 g1264) + (g1261 + g1264 + (cons (g1253 g1265) + g1262))) + (modulo g1263 g1251) + (quotient g1263 g1251)))))) + g1261) + g1260 + '()))) + (g1253 + (lambda (g1259) (integer->char (+ g1259 '33)))) + (g1252 (lambda () '0))) + ((lambda (g1256 g1255) + (lambda (g1257) + (begin (set! g1255 (+ g1255 '1)) + ((lambda (g1258) g1258) + (string->symbol + (string-append + '"#" + g1256 + (g1254 g1255))))))) + (g1254 (g1252)) + '-1))) + (- '127 '32 '2))) + (g100 (lambda (g1241 g1240) (getprop g1241 g1240))) + (g99 (lambda (g1250) (getprop g1250 '*sc-expander*))) + (g98 (lambda (g1243 g1242) ($sc-put-cte g1243 g1242))) + (g93 + (lambda (g1249 g1247 g1248) + (error g1249 '"~a ~s" g1247 g1248))) + (g92 (lambda (g1244) (eval (list g53 g1244)))) + (g91 (lambda (g1246) (eval (list g53 g1246)))) + (g90 (lambda (g1245) '#f)) + (g53 '"noexpand")) + (begin (set! $sc-put-cte + (lambda (g802 g801) + (letrec ((g805 + (lambda (g831 g830) + ((lambda (g832) + (putprop g832 '*sc-expander* g830)) + (if (symbol? g831) g831 (g377 g831 '(())))))) + (g804 + (lambda (g815 g814) + (g429 (lambda (g816) (g803 g816 g814)) g815))) + (g803 + (lambda (g818 g817) + (letrec ((g820 + (lambda (g828 g827) + (if (pair? g827) + (if (g388 (car g827) g828) + (g820 g828 (cdr g827)) + (g819 (car g827) + (g820 g828 + (cdr g827)))) + (if ((lambda (g829) + (if g829 + g829 + (g388 g827 g828))) + (not g827)) + '#f + g827)))) + (g819 + (lambda (g826 g825) + (if (not g825) + g826 + (cons g826 g825))))) + ((lambda (g821) + ((lambda (g822) + (if (if (not g822) (symbol? g818) '#f) + (remprop g821 g817) + (putprop + g821 + g817 + (g819 g818 g822)))) + (g820 g818 (getprop g821 g817)))) + ((lambda (g823) + ((lambda (g824) + (if (g90 g824) + (annotation-expression g824) + g824)) + (if (g204 g823) (g205 g823) g823))) + g818)))))) + ((lambda (g806) + ((lambda (g807) + (if (memv g807 '(module)) + (begin ((lambda (g808) + (g804 (g404 g808) (g405 g808))) + (g233 g806)) + (g805 g802 g806)) + (if (memv g807 '(do-import)) + ((lambda (g809) + ((lambda (g810) + ((lambda (g811) + (if (memv g811 '(module)) + ((lambda (g812) + (begin (if (not (eq? (g405 g812) + g809)) + (syntax-error + g802 + '"import mismatch for module") + (void)) + (g804 (g404 g812) + '*top*))) + (g233 g810)) + (syntax-error + g802 + '"import from unknown module"))) + (g232 g810))) + (g253 (g377 g802 '(())) '()))) + (g233 g801)) + (g805 g802 g806)))) + (g232 g806))) + ((lambda (g813) + (if g813 + g813 + (error 'define-syntax + '"invalid transformer ~s" + g801))) + (g252 g801)))))) + (g254 'local-syntax 'letrec-syntax '#t) + (g254 'local-syntax 'let-syntax '#f) + (g254 'core + 'fluid-let-syntax + (lambda (g456 g453 g455 g454) + ((lambda (g457) + ((lambda (g458) + (if (if g458 + (apply + (lambda (g463 g459 g462 g460 g461) + (g389 g459)) + g458) + '#f) + (apply + (lambda (g469 g465 g468 g466 g467) + ((lambda (g470) + (begin (for-each + (lambda (g477 g476) + ((lambda (g478) + (if (memv g478 + '(displaced-lexical)) + (g250 (g393 g477 + g455)) + (void))) + (g232 (g253 g476 g453)))) + g465 + g470) + (g437 (cons g466 g467) + (g394 g456 g455 g454) + (g247 g470 + ((lambda (g471) + (map (lambda (g473) + (g231 'deferred + (g432 g473 + g471 + g455))) + g468)) + (g249 g453)) + g453) + g455))) + (map (lambda (g480) (g377 g480 g455)) + g465))) + g458) + ((lambda (g481) + (syntax-error (g394 g456 g455 g454))) + g457))) + ($syntax-dispatch + g457 + '(any #(each (any any)) any . each-any)))) + g456))) + (g254 'core + 'quote + (lambda (g795 g792 g794 g793) + ((lambda (g796) + ((lambda (g797) + (if g797 + (apply + (lambda (g799 g798) + (list 'quote (g450 g798 g794))) + g797) + ((lambda (g800) + (syntax-error (g394 g795 g794 g793))) + g796))) + ($syntax-dispatch g796 '(any any)))) + g795))) + (g254 'core + 'syntax + ((lambda () + (letrec ((g489 + (lambda (g584) + ((lambda (g585) + (if (memv g585 '(ref)) + (cadr g584) + (if (memv g585 '(primitive)) + (cadr g584) + (if (memv g585 '(quote)) + (list 'quote (cadr g584)) + (if (memv g585 '(lambda)) + (list 'lambda + (cadr g584) + (g489 (caddr + g584))) + (if (memv g585 '(map)) + ((lambda (g586) + (cons (if (= (length + g586) + '2) + 'map + 'map) + g586)) + (map g489 + (cdr g584))) + (cons (car g584) + (map g489 + (cdr g584))))))))) + (car g584)))) + (g488 + (lambda (g502) + (if (eq? (car g502) 'list) + (cons 'vector (cdr g502)) + (if (eq? (car g502) 'quote) + (list 'quote + (list->vector (cadr g502))) + (list 'list->vector g502))))) + (g487 + (lambda (g583 g582) + (if (equal? g582 ''()) + g583 + (list 'append g583 g582)))) + (g486 + (lambda (g504 g503) + ((lambda (g505) + (if (memv g505 '(quote)) + (if (eq? (car g504) 'quote) + (list 'quote + (cons (cadr g504) + (cadr g503))) + (if (eq? (cadr g503) '()) + (list 'list g504) + (list 'cons g504 g503))) + (if (memv g505 '(list)) + (cons 'list + (cons g504 (cdr g503))) + (list 'cons g504 g503)))) + (car g503)))) + (g485 + (lambda (g575 g574) + ((lambda (g577 g576) + (if (eq? (car g575) 'ref) + (car g576) + (if (andmap + (lambda (g578) + (if (eq? (car g578) 'ref) + (memq (cadr g578) g577) + '#f)) + (cdr g575)) + (cons 'map + (cons (list 'primitive + (car g575)) + (map ((lambda (g579) + (lambda (g580) + (cdr (assq (cadr g580) + g579)))) + (map cons + g577 + g576)) + (cdr g575)))) + (cons 'map + (cons (list 'lambda + g577 + g575) + g576))))) + (map cdr g574) + (map (lambda (g581) + (list 'ref (car g581))) + g574)))) + (g484 + (lambda (g507 g506) + (list 'apply + '(primitive append) + (g485 g507 g506)))) + (g483 + (lambda (g569 g566 g568 g567) + (if (= g568 '0) + (values g566 g567) + (if (null? g567) + (syntax-error + g569 + '"missing ellipsis in syntax form") + (call-with-values + (lambda () + (g483 g569 + g566 + (- g568 '1) + (cdr g567))) + (lambda (g571 g570) + ((lambda (g572) + (if g572 + (values + (cdr g572) + g567) + ((lambda (g573) + (values + g573 + (cons (cons (cons g571 + g573) + (car g567)) + g570))) + (g451 'tmp)))) + (assq g571 (car g567))))))))) + (g482 + (lambda (g512 g508 g511 g509 g510) + (if (g256 g508) + ((lambda (g513) + ((lambda (g514) + (if (eq? (g232 g514) 'syntax) + (call-with-values + (lambda () + ((lambda (g517) + (g483 g512 + (car g517) + (cdr g517) + g509)) + (g233 g514))) + (lambda (g516 g515) + (values + (list 'ref g516) + g515))) + (if (g510 g508) + (syntax-error + g512 + '"misplaced ellipsis in syntax form") + (values + (list 'quote g508) + g509)))) + (g253 g513 g511))) + (g377 g508 '(()))) + ((lambda (g518) + ((lambda (g519) + (if (if g519 + (apply + (lambda (g521 g520) + (g510 g521)) + g519) + '#f) + (apply + (lambda (g523 g522) + (g482 g512 + g522 + g511 + g509 + (lambda (g524) + '#f))) + g519) + ((lambda (g525) + (if (if g525 + (apply + (lambda (g528 + g526 + g527) + (g510 g526)) + g525) + '#f) + (apply + (lambda (g531 + g529 + g530) + ((letrec ((g532 + (lambda (g534 + g533) + ((lambda (g535) + ((lambda (g536) + (if (if g536 + (apply + (lambda (g538 + g537) + (g510 g538)) + g536) + '#f) + (apply + (lambda (g540 + g539) + (g532 g539 + (lambda (g541) + (call-with-values + (lambda () + (g533 (cons '() + g541))) + (lambda (g543 + g542) + (if (null? + (car g542)) + (syntax-error + g512 + '"extra ellipsis in syntax form") + (values + (g484 g543 + (car g542)) + (cdr g542)))))))) + g536) + ((lambda (g544) + (call-with-values + (lambda () + (g482 g512 + g534 + g511 + g509 + g510)) + (lambda (g546 + g545) + (call-with-values + (lambda () + (g533 g545)) + (lambda (g548 + g547) + (values + (g487 g548 + g546) + g547)))))) + g535))) + ($syntax-dispatch + g535 + '(any . + any)))) + g534)))) + g532) + g530 + (lambda (g549) + (call-with-values + (lambda () + (g482 g512 + g531 + g511 + (cons '() + g549) + g510)) + (lambda (g551 + g550) + (if (null? + (car g550)) + (syntax-error + g512 + '"extra ellipsis in syntax form") + (values + (g485 g551 + (car g550)) + (cdr g550)))))))) + g525) + ((lambda (g552) + (if g552 + (apply + (lambda (g554 + g553) + (call-with-values + (lambda () + (g482 g512 + g554 + g511 + g509 + g510)) + (lambda (g556 + g555) + (call-with-values + (lambda () + (g482 g512 + g553 + g511 + g555 + g510)) + (lambda (g558 + g557) + (values + (g486 g556 + g558) + g557)))))) + g552) + ((lambda (g559) + (if g559 + (apply + (lambda (g561 + g560) + (call-with-values + (lambda () + (g482 g512 + (cons g561 + g560) + g511 + g509 + g510)) + (lambda (g563 + g562) + (values + (g488 g563) + g562)))) + g559) + ((lambda (g565) + (values + (list 'quote + g508) + g509)) + g518))) + ($syntax-dispatch + g518 + '#(vector + (any . + each-any)))))) + ($syntax-dispatch + g518 + '(any . any))))) + ($syntax-dispatch + g518 + '(any any . any))))) + ($syntax-dispatch + g518 + '(any any)))) + g508))))) + (lambda (g493 g490 g492 g491) + ((lambda (g494) + ((lambda (g495) + ((lambda (g496) + (if g496 + (apply + (lambda (g498 g497) + (call-with-values + (lambda () + (g482 g494 + g497 + g490 + '() + g447)) + (lambda (g500 g499) + (g489 g500)))) + g496) + ((lambda (g501) (syntax-error g494)) + g495))) + ($syntax-dispatch g495 '(any any)))) + g494)) + (g394 g493 g492 g491))))))) + (g254 'core + 'lambda + (lambda (g785 g782 g784 g783) + ((lambda (g786) + ((lambda (g787) + (if g787 + (apply + (lambda (g789 g788) + (g444 (g394 g785 g784 g783) + g788 + g782 + g784 + (lambda (g791 g790) + (list 'lambda g791 g790)))) + g787) + (syntax-error g786))) + ($syntax-dispatch g786 '(any . any)))) + g785))) + (g254 'core + 'letrec + (lambda (g590 g587 g589 g588) + ((lambda (g591) + ((lambda (g592) + (if g592 + (apply + (lambda (g597 g593 g596 g594 g595) + ((lambda (g598) + (if (not (g389 g598)) + (g391 (map (lambda (g599) + (g393 g599 g589)) + g598) + (g394 g590 g589 g588) + '"bound variable") + ((lambda (g601 g600) + ((lambda (g603 g602) + (g191 g588 + g600 + (map (lambda (g606) + (g432 g606 + g602 + g603)) + g596) + (g437 (cons g594 g595) + (g394 g590 + g603 + g588) + g602 + g603))) + (g368 g598 g601 g589) + (g248 g601 g600 g587))) + (g299 g598) + (map g451 g598)))) + g593)) + g592) + ((lambda (g608) + (syntax-error (g394 g590 g589 g588))) + g591))) + ($syntax-dispatch + g591 + '(any #(each (any any)) any . each-any)))) + g590))) + (g254 'core + 'if + (lambda (g770 g767 g769 g768) + ((lambda (g771) + ((lambda (g772) + (if g772 + (apply + (lambda (g775 g773 g774) + (list 'if + (g432 g773 g767 g769) + (g432 g774 g767 g769) + (g446))) + g772) + ((lambda (g776) + (if g776 + (apply + (lambda (g780 g777 g779 g778) + (list 'if + (g432 g777 g767 g769) + (g432 g779 g767 g769) + (g432 g778 g767 g769))) + g776) + ((lambda (g781) + (syntax-error + (g394 g770 g769 g768))) + g771))) + ($syntax-dispatch + g771 + '(any any any any))))) + ($syntax-dispatch g771 '(any any any)))) + g770))) + (g254 'set! 'set! '()) + (g254 'begin 'begin '()) + (g254 'module-key 'module '()) + (g254 'import 'import '#f) + (g254 'import 'import-only '#t) + (g254 'define 'define '()) + (g254 'define-syntax 'define-syntax '()) + (g254 'eval-when 'eval-when '()) + (g254 'core + 'syntax-case + ((lambda () + (letrec ((g612 + (lambda (g693 g690 g692 g691) + (if (null? g692) + (list 'syntax-error g693) + ((lambda (g694) + ((lambda (g695) + (if g695 + (apply + (lambda (g697 g696) + (if (if (g256 g697) + (if (not (g392 g697 + g690)) + (not (g447 g697)) + '#f) + '#f) + ((lambda (g699 g698) + (list (list 'lambda + (list g698) + (g432 g696 + (g246 g699 + (g231 'syntax + (cons g698 + '0)) + g691) + (g368 (list g697) + (list g699) + '(())))) + g693)) + (g297) + (g451 g697)) + (g611 g693 + g690 + (cdr g692) + g691 + g697 + '#t + g696))) + g695) + ((lambda (g700) + (if g700 + (apply + (lambda (g703 + g701 + g702) + (g611 g693 + g690 + (cdr g692) + g691 + g703 + g701 + g702)) + g700) + ((lambda (g704) + (syntax-error + (car g692) + '"invalid syntax-case clause")) + g694))) + ($syntax-dispatch + g694 + '(any any any))))) + ($syntax-dispatch + g694 + '(any any)))) + (car g692))))) + (g611 + (lambda (g635 g629 g634 g630 g633 g631 g632) + (call-with-values + (lambda () (g609 g633 g629)) + (lambda (g637 g636) + (if (not (g390 (map car g636))) + (g391 (map car g636) + g633 + '"pattern variable") + (if (not (andmap + (lambda (g638) + (not (g447 (car g638)))) + g636)) + (syntax-error + g633 + '"misplaced ellipsis in syntax-case pattern") + ((lambda (g639) + (list (list 'lambda + (list g639) + (list 'if + ((lambda (g649) + ((lambda (g650) + (if g650 + (apply + (lambda () + g639) + g650) + ((lambda (g651) + (list 'if + g639 + (g610 g636 + g631 + g639 + g630) + (list 'quote + '#f))) + g649))) + ($syntax-dispatch + g649 + '#(atom + #t)))) + g631) + (g610 g636 + g632 + g639 + g630) + (g612 g635 + g629 + g634 + g630))) + (if (eq? g637 'any) + (list 'list g635) + (list '$syntax-dispatch + g635 + (list 'quote + g637))))) + (g451 'tmp)))))))) + (g610 + (lambda (g683 g680 g682 g681) + ((lambda (g685 g684) + ((lambda (g687 g686) + (list 'apply + (list 'lambda + g686 + (g432 g680 + (g247 g687 + (map (lambda (g689 + g688) + (g231 'syntax + (cons g689 + g688))) + g686 + (map cdr + g683)) + g681) + (g368 g685 + g687 + '(())))) + g682)) + (g299 g685) + (map g451 g685))) + (map car g683) + (map cdr g683)))) + (g609 + (lambda (g653 g652) + ((letrec ((g654 + (lambda (g657 g655 g656) + (if (g256 g657) + (if (g392 g657 g652) + (values + (vector + 'free-id + g657) + g656) + (values + 'any + (cons (cons g657 + g655) + g656))) + ((lambda (g658) + ((lambda (g659) + (if (if g659 + (apply + (lambda (g661 + g660) + (g447 g660)) + g659) + '#f) + (apply + (lambda (g663 + g662) + (call-with-values + (lambda () + (g654 g663 + (+ g655 + '1) + g656)) + (lambda (g665 + g664) + (values + (if (eq? g665 + 'any) + 'each-any + (vector + 'each + g665)) + g664)))) + g659) + ((lambda (g666) + (if g666 + (apply + (lambda (g668 + g667) + (call-with-values + (lambda () + (g654 g667 + g655 + g656)) + (lambda (g670 + g669) + (call-with-values + (lambda () + (g654 g668 + g655 + g669)) + (lambda (g672 + g671) + (values + (cons g672 + g670) + g671)))))) + g666) + ((lambda (g673) + (if g673 + (apply + (lambda () + (values + '() + g656)) + g673) + ((lambda (g674) + (if g674 + (apply + (lambda (g675) + (call-with-values + (lambda () + (g654 g675 + g655 + g656)) + (lambda (g677 + g676) + (values + (vector + 'vector + g677) + g676)))) + g674) + ((lambda (g679) + (values + (vector + 'atom + (g450 g657 + '(()))) + g656)) + g658))) + ($syntax-dispatch + g658 + '#(vector + each-any))))) + ($syntax-dispatch + g658 + '())))) + ($syntax-dispatch + g658 + '(any . + any))))) + ($syntax-dispatch + g658 + '(any any)))) + g657))))) + g654) + g653 + '0 + '())))) + (lambda (g616 g613 g615 g614) + ((lambda (g617) + ((lambda (g618) + ((lambda (g619) + (if g619 + (apply + (lambda (g623 g620 g622 g621) + (if (andmap + (lambda (g625) + (if (g256 g625) + (not (g447 g625)) + '#f)) + g622) + ((lambda (g626) + (list (list 'lambda + (list g626) + (g612 g626 + g622 + g621 + g613)) + (g432 g620 + g613 + '(())))) + (g451 'tmp)) + (syntax-error + g617 + '"invalid literals list in"))) + g619) + (syntax-error g618))) + ($syntax-dispatch + g618 + '(any any each-any . each-any)))) + g617)) + (g394 g616 g615 g614))))))) + (set! sc-expand + ((lambda (g763 g761 g762) + ((lambda (g764) + (lambda (g765) + (if (if (pair? g765) (equal? (car g765) g53) '#f) + (cadr g765) + (g400 g765 '() g764 g763 g761 g762)))) + (g263 (g264 '((top))) (cons g762 (g265 '((top))))))) + 'c + '(eval load compile) + ((lambda (g766) (begin (g366 g766 '*top*) g766)) + (g304 '() '() '())))) + (set! identifier? (lambda (g705) (g255 g705))) + (set! datum->syntax-object + (lambda (g759 g758) + (begin ((lambda (g760) + (if (not (g255 g760)) + (g93 'datum->syntax-object + '"invalid argument" + g760) + (void))) + g759) + (g203 g758 (g206 g759))))) + (set! syntax-object->datum + (lambda (g706) (g450 g706 '(())))) + (set! generate-temporaries + (lambda (g755) + (begin ((lambda (g757) + (if (not (list? g757)) + (g93 'generate-temporaries + '"invalid argument" + g757) + (void))) + g755) + (map (lambda (g756) (g393 (gensym) '((top)))) + g755)))) + (set! free-identifier=? + (lambda (g708 g707) + (begin ((lambda (g710) + (if (not (g255 g710)) + (g93 'free-identifier=? + '"invalid argument" + g710) + (void))) + g708) + ((lambda (g709) + (if (not (g255 g709)) + (g93 'free-identifier=? + '"invalid argument" + g709) + (void))) + g707) + (g378 g708 g707)))) + (set! bound-identifier=? + (lambda (g752 g751) + (begin ((lambda (g754) + (if (not (g255 g754)) + (g93 'bound-identifier=? + '"invalid argument" + g754) + (void))) + g752) + ((lambda (g753) + (if (not (g255 g753)) + (g93 'bound-identifier=? + '"invalid argument" + g753) + (void))) + g751) + (g388 g752 g751)))) + (set! syntax-error + (lambda (g711 . g712) + (begin (for-each + (lambda (g714) + ((lambda (g715) + (if (not (string? g715)) + (g93 'syntax-error + '"invalid argument" + g715) + (void))) + g714)) + g712) + ((lambda (g713) (g93 '#f g713 (g450 g711 '(())))) + (if (null? g712) + '"invalid syntax" + (apply string-append g712)))))) + ((lambda () + (letrec ((g720 + (lambda (g748 g745 g747 g746) + (if (not g746) + '#f + (if (eq? g745 'any) + (cons (g393 g748 g747) g746) + (if (g204 g748) + (g719 ((lambda (g749) + (if (g90 g749) + (annotation-expression + g749) + g749)) + (g205 g748)) + g745 + (g371 g747 (g206 g748)) + g746) + (g719 ((lambda (g750) + (if (g90 g750) + (annotation-expression + g750) + g750)) + g748) + g745 + g747 + g746)))))) + (g719 + (lambda (g728 g725 g727 g726) + (if (null? g725) + (if (null? g728) g726 '#f) + (if (pair? g725) + (if (pair? g728) + (g720 (car g728) + (car g725) + g727 + (g720 (cdr g728) + (cdr g725) + g727 + g726)) + '#f) + (if (eq? g725 'each-any) + ((lambda (g729) + (if g729 (cons g729 g726) '#f)) + (g717 g728 g727)) + ((lambda (g730) + (if (memv g730 '(each)) + (if (null? g728) + (g718 (vector-ref + g725 + '1) + g726) + ((lambda (g731) + (if g731 + ((letrec ((g732 + (lambda (g733) + (if (null? + (car g733)) + g726 + (cons (map car + g733) + (g732 (map cdr + g733))))))) + g732) + g731) + '#f)) + (g716 g728 + (vector-ref + g725 + '1) + g727))) + (if (memv g730 '(free-id)) + (if (g256 g728) + (if (g378 (g393 g728 + g727) + (vector-ref + g725 + '1)) + g726 + '#f) + '#f) + (if (memv g730 '(atom)) + (if (equal? + (vector-ref + g725 + '1) + (g450 g728 + g727)) + g726 + '#f) + (if (memv g730 + '(vector)) + (if (vector? + g728) + (g720 (vector->list + g728) + (vector-ref + g725 + '1) + g727 + g726) + '#f) + (void)))))) + (vector-ref g725 '0))))))) + (g718 + (lambda (g743 g742) + (if (null? g743) + g742 + (if (eq? g743 'any) + (cons '() g742) + (if (pair? g743) + (g718 (car g743) + (g718 (cdr g743) g742)) + (if (eq? g743 'each-any) + (cons '() g742) + ((lambda (g744) + (if (memv g744 '(each)) + (g718 (vector-ref + g743 + '1) + g742) + (if (memv g744 + '(free-id + atom)) + g742 + (if (memv g744 + '(vector)) + (g718 (vector-ref + g743 + '1) + g742) + (void))))) + (vector-ref g743 '0)))))))) + (g717 + (lambda (g735 g734) + (if (g90 g735) + (g717 (annotation-expression g735) g734) + (if (pair? g735) + ((lambda (g736) + (if g736 + (cons (g393 (car g735) g734) + g736) + '#f)) + (g717 (cdr g735) g734)) + (if (null? g735) + '() + (if (g204 g735) + (g717 (g205 g735) + (g371 g734 (g206 g735))) + '#f)))))) + (g716 + (lambda (g739 g737 g738) + (if (g90 g739) + (g716 (annotation-expression g739) + g737 + g738) + (if (pair? g739) + ((lambda (g740) + (if g740 + ((lambda (g741) + (if g741 + (cons g740 g741) + '#f)) + (g716 (cdr g739) g737 g738)) + '#f)) + (g720 (car g739) g737 g738 '())) + (if (null? g739) + '() + (if (g204 g739) + (g716 (g205 g739) + g737 + (g371 g738 (g206 g739))) + '#f))))))) + (set! $syntax-dispatch + (lambda (g722 g721) + (if (eq? g721 'any) + (list g722) + (if (g204 g722) + (g719 ((lambda (g723) + (if (g90 g723) + (annotation-expression g723) + g723)) + (g205 g722)) + g721 + (g206 g722) + '()) + (g719 ((lambda (g724) + (if (g90 g724) + (annotation-expression g724) + g724)) + g722) + g721 + '(()) + '())))))))))))) +($sc-put-cte + 'with-syntax + (lambda (g1828) + ((lambda (g1829) + ((lambda (g1830) + (if g1830 + (apply + (lambda (g1833 g1831 g1832) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ e1 e2) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ()))) + (cons g1831 g1832))) + g1830) + ((lambda (g1835) + (if g1835 + (apply + (lambda (g1840 g1836 g1839 g1837 g1838) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g1839 + '() + (list g1836 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g1837 g1838))))) + g1835) + ((lambda (g1842) + (if g1842 + (apply + (lambda (g1847 g1843 g1846 g1844 g1845) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons '#(syntax-object + list + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g1846) + '() + (list g1843 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1844 g1845))))) + g1842) + (syntax-error g1829))) + ($syntax-dispatch + g1829 + '(any #(each (any any)) any . each-any))))) + ($syntax-dispatch + g1829 + '(any ((any any)) any . each-any))))) + ($syntax-dispatch g1829 '(any () any . each-any)))) + g1828))) +($sc-put-cte + 'syntax-rules + (lambda (g1851) + ((lambda (g1852) + ((lambda (g1853) + (if g1853 + (apply + (lambda (g1858 g1854 g1857 g1855 g1856) + (list '#(syntax-object + lambda + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ()))) + '(#(syntax-object + x + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ())))) + (cons '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons '#(syntax-object + x + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g1854 + (map (lambda (g1861 g1860) + (list (cons '#(syntax-object + dummy + ((top) + #(ribcage + #(_ + k + keyword + pattern + template) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1860) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + k + keyword + pattern + template) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1861))) + g1856 + g1855)))))) + g1853) + (syntax-error g1852))) + ($syntax-dispatch + g1852 + '(any each-any . #(each ((any . any) any)))))) + g1851))) +($sc-put-cte + 'or + (lambda (g1862) + ((lambda (g1863) + ((lambda (g1864) + (if g1864 + (apply + (lambda (g1865) + '#(syntax-object + #f + ((top) + #(ribcage #(_) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ())))) + g1864) + ((lambda (g1866) + (if g1866 + (apply (lambda (g1868 g1867) g1867) g1866) + ((lambda (g1869) + (if g1869 + (apply + (lambda (g1873 g1870 g1872 g1871) + (list '#(syntax-object + let + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1870)) + (list '#(syntax-object + if + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons '#(syntax-object + or + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1872 g1871))))) + g1869) + (syntax-error g1863))) + ($syntax-dispatch g1863 '(any any any . each-any))))) + ($syntax-dispatch g1863 '(any any))))) + ($syntax-dispatch g1863 '(any)))) + g1862))) +($sc-put-cte + 'and + (lambda (g1875) + ((lambda (g1876) + ((lambda (g1877) + (if g1877 + (apply + (lambda (g1881 g1878 g1880 g1879) + (cons '#(syntax-object + if + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ()))) + (cons g1878 + (cons (cons '#(syntax-object + and + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g1880 g1879)) + '(#(syntax-object + #f + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))))))) + g1877) + ((lambda (g1883) + (if g1883 + (apply (lambda (g1885 g1884) g1884) g1883) + ((lambda (g1886) + (if g1886 + (apply + (lambda (g1887) + '#(syntax-object + #t + ((top) + #(ribcage #(_) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + g1886) + (syntax-error g1876))) + ($syntax-dispatch g1876 '(any))))) + ($syntax-dispatch g1876 '(any any))))) + ($syntax-dispatch g1876 '(any any any . each-any)))) + g1875))) +($sc-put-cte + 'let + (lambda (g1888) + ((lambda (g1889) + ((lambda (g1890) + (if (if g1890 + (apply + (lambda (g1895 g1891 g1894 g1892 g1893) + (andmap identifier? g1891)) + g1890) + '#f) + (apply + (lambda (g1901 g1897 g1900 g1898 g1899) + (cons (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ x v e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g1897 (cons g1898 g1899))) + g1900)) + g1890) + ((lambda (g1905) + (if (if g1905 + (apply + (lambda (g1911 g1906 g1910 g1907 g1909 g1908) + (andmap identifier? (cons g1906 g1910))) + g1905) + '#f) + (apply + (lambda (g1918 g1913 g1917 g1914 g1916 g1915) + (cons (list '#(syntax-object + letrec + ((top) + #(ribcage + #(_ f x v e1 e2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (list (list g1913 + (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ + f + x + v + e1 + e2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1917 + (cons g1916 + g1915))))) + g1913) + g1914)) + g1905) + (syntax-error g1889))) + ($syntax-dispatch + g1889 + '(any any #(each (any any)) any . each-any))))) + ($syntax-dispatch + g1889 + '(any #(each (any any)) any . each-any)))) + g1888))) +($sc-put-cte + 'let* + (lambda (g1922) + ((lambda (g1923) + ((lambda (g1924) + (if (if g1924 + (apply + (lambda (g1929 g1925 g1928 g1926 g1927) + (andmap identifier? g1925)) + g1924) + '#f) + (apply + (lambda (g1935 g1931 g1934 g1932 g1933) + ((letrec ((g1936 + (lambda (g1937) + (if (null? g1937) + (cons '#(syntax-object + let + ((top) + #(ribcage () () ()) + #(ribcage + #(bindings) + #((top)) + #("i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(let* x v e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons '() (cons g1932 g1933))) + ((lambda (g1939) + ((lambda (g1940) + (if g1940 + (apply + (lambda (g1942 g1941) + (list '#(syntax-object + let + ((top) + #(ribcage + #(body + binding) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(bindings) + #((top)) + #("i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(let* + x + v + e1 + e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list g1941) + g1942)) + g1940) + (syntax-error g1939))) + ($syntax-dispatch + g1939 + '(any any)))) + (list (g1936 (cdr g1937)) + (car g1937))))))) + g1936) + (map list g1931 g1934))) + g1924) + (syntax-error g1923))) + ($syntax-dispatch + g1923 + '(any #(each (any any)) any . each-any)))) + g1922))) +($sc-put-cte + 'cond + (lambda (g1945) + ((lambda (g1946) + ((lambda (g1947) + (if g1947 + (apply + (lambda (g1950 g1948 g1949) + ((letrec ((g1951 + (lambda (g1953 g1952) + (if (null? g1952) + ((lambda (g1954) + ((lambda (g1955) + (if g1955 + (apply + (lambda (g1957 g1956) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 e2) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ m1 m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1957 g1956))) + g1955) + ((lambda (g1959) + (if g1959 + (apply + (lambda (g1960) + (cons '#(syntax-object + let + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons (list (list '#(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1960)) + '((#(syntax-object + if + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))))))) + g1959) + ((lambda (g1961) + (if g1961 + (apply + (lambda (g1963 + g1962) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1963)) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1962 + '(#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))))))) + g1961) + ((lambda (g1964) + (if g1964 + (apply + (lambda (g1967 + g1965 + g1966) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0 + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1967 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e0 + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1965 + g1966)))) + g1964) + ((lambda (g1969) + (syntax-error + g1945)) + g1954))) + ($syntax-dispatch + g1954 + '(any any + . + each-any))))) + ($syntax-dispatch + g1954 + '(any #(free-id + #(syntax-object + => + ((top) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + any))))) + ($syntax-dispatch + g1954 + '(any))))) + ($syntax-dispatch + g1954 + '(#(free-id + #(syntax-object + else + ((top) + #(ribcage () () ()) + #(ribcage + #(clause clauses) + #((top) (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ m1 m2) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + any + . + each-any)))) + g1953) + ((lambda (g1970) + ((lambda (g1971) + ((lambda (g1972) + ((lambda (g1973) + (if g1973 + (apply + (lambda (g1974) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1974)) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1971))) + g1973) + ((lambda (g1975) + (if g1975 + (apply + (lambda (g1977 + g1976) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1977)) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1976 + '(#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))))) + g1971))) + g1975) + ((lambda (g1978) + (if g1978 + (apply + (lambda (g1981 + g1979 + g1980) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0 + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1981 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e0 + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1979 + g1980)) + g1971)) + g1978) + ((lambda (g1983) + (syntax-error + g1945)) + g1972))) + ($syntax-dispatch + g1972 + '(any any + . + each-any))))) + ($syntax-dispatch + g1972 + '(any #(free-id + #(syntax-object + => + ((top) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + any))))) + ($syntax-dispatch + g1972 + '(any)))) + g1953)) + g1970)) + (g1951 (car g1952) (cdr g1952))))))) + g1951) + g1948 + g1949)) + g1947) + (syntax-error g1946))) + ($syntax-dispatch g1946 '(any any . each-any)))) + g1945))) +($sc-put-cte + 'do + (lambda (g1985) + ((lambda (g1986) + ((lambda (g1987) + (if g1987 + (apply + (lambda (g1994 g1988 g1993 g1989 g1992 g1990 g1991) + ((lambda (g1995) + ((lambda (g2005) + (if g2005 + (apply + (lambda (g2006) + ((lambda (g2007) + ((lambda (g2009) + (if g2009 + (apply + (lambda () + (list '#(syntax-object + let + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + doloop + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (map list g1988 g1993) + (list '#(syntax-object + if + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + not + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1992) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (append + g1991 + (list (cons '#(syntax-object + doloop + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2006))))))) + g2009) + ((lambda (g2014) + (if g2014 + (apply + (lambda (g2016 g2015) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e1 e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + doloop + ((top) + #(ribcage + #(e1 e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (map list + g1988 + g1993) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1992 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2016 + g2015)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (append + g1991 + (list (cons '#(syntax-object + doloop + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2006))))))) + g2014) + (syntax-error g2007))) + ($syntax-dispatch + g2007 + '(any . each-any))))) + ($syntax-dispatch g2007 '()))) + g1990)) + g2005) + (syntax-error g1995))) + ($syntax-dispatch g1995 'each-any))) + (map (lambda (g1999 g1998) + ((lambda (g2000) + ((lambda (g2001) + (if g2001 + (apply (lambda () g1999) g2001) + ((lambda (g2002) + (if g2002 + (apply + (lambda (g2003) g2003) + g2002) + ((lambda (g2004) + (syntax-error g1985)) + g2000))) + ($syntax-dispatch g2000 '(any))))) + ($syntax-dispatch g2000 '()))) + g1998)) + g1988 + g1989))) + g1987) + (syntax-error g1986))) + ($syntax-dispatch + g1986 + '(any #(each (any any . any)) + (any . each-any) + . + each-any)))) + g1985))) +($sc-put-cte + 'quasiquote + (letrec ((g2030 + (lambda (g2142) + (if (identifier? g2142) + (free-identifier=? + g2142 + '#(syntax-object + quote + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ())))) + '#f))) + (g2022 + (lambda (g2036) + (if (identifier? g2036) + (free-identifier=? + g2036 + '#(syntax-object + list + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ())))) + '#f))) + (g2029 + (lambda (g2141) + (if (identifier? g2141) + (free-identifier=? + g2141 + '#(syntax-object + cons + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ())))) + '#f))) + (g2023 + (lambda (g2037) + ((lambda (g2038) + ((lambda (g2039) + (if g2039 + (apply (lambda (g2040) (g2030 g2040)) g2039) + ((lambda (g2041) '#f) g2038))) + ($syntax-dispatch g2038 '(any ())))) + g2037))) + (g2028 + (lambda (g2138 g2137) + ((letrec ((g2139 + (lambda (g2140) + (if (null? g2140) + g2137 + (g2024 (car g2140) (g2139 (cdr g2140))))))) + g2139) + g2138))) + (g2024 + (lambda (g2043 g2042) + ((lambda (g2044) + ((lambda (g2045) + (if g2045 + (apply + (lambda (g2047 g2046) + ((lambda (g2048) + ((lambda (g2049) + (if (if g2049 + (apply + (lambda (g2051 g2050) + (g2030 g2051)) + g2049) + '#f) + (apply + (lambda (g2053 g2052) + ((lambda (g2054) + ((lambda (g2055) + (if (if g2055 + (apply + (lambda (g2057 + g2056) + (g2030 g2057)) + g2055) + '#f) + (apply + (lambda (g2059 g2058) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(quote? + dx) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quote? + dy) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(x y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2058 + g2052))) + g2055) + ((lambda (g2060) + (if (null? g2052) + (list '#(syntax-object + list + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(quote? + dy) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2047) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(quote? + dy) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2047 + g2046))) + g2054))) + ($syntax-dispatch + g2054 + '(any any)))) + g2047)) + g2049) + ((lambda (g2061) + (if (if g2061 + (apply + (lambda (g2063 g2062) + (g2022 g2063)) + g2061) + '#f) + (apply + (lambda (g2065 g2064) + (cons '#(syntax-object + list + ((top) + #(ribcage + #(listp stuff) + #((top) (top)) + #("i" "i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2047 g2064))) + g2061) + ((lambda (g2066) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(else) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2047 + g2046)) + g2048))) + ($syntax-dispatch + g2048 + '(any . any))))) + ($syntax-dispatch g2048 '(any any)))) + g2046)) + g2045) + (syntax-error g2044))) + ($syntax-dispatch g2044 '(any any)))) + (list g2043 g2042)))) + (g2027 + (lambda (g2129 g2128) + ((lambda (g2130) + (if (null? g2130) + '(#(syntax-object + quote + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(ls) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x y) #((top) (top)) #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ()))) + ()) + (if (null? (cdr g2130)) + (car g2130) + ((lambda (g2131) + ((lambda (g2132) + (if g2132 + (apply + (lambda (g2133) + (cons '#(syntax-object + append + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(ls) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2133)) + g2132) + (syntax-error g2131))) + ($syntax-dispatch g2131 'each-any))) + g2130)))) + ((letrec ((g2135 + (lambda (g2136) + (if (null? g2136) + (if (g2023 g2128) '() (list g2128)) + (if (g2023 (car g2136)) + (g2135 (cdr g2136)) + (cons (car g2136) + (g2135 (cdr g2136)))))))) + g2135) + g2129)))) + (g2025 + (lambda (g2067) + ((lambda (g2068) + ((lambda (g2069) + ((lambda (g2070) + ((lambda (g2071) + (if (if g2071 + (apply + (lambda (g2073 g2072) (g2030 g2073)) + g2071) + '#f) + (apply + (lambda (g2075 g2074) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(quote? x) + #((top) (top)) + #("i" "i")) + #(ribcage + #(pat-x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (list->vector g2074))) + g2071) + ((lambda (g2077) + ((letrec ((g2078 + (lambda (g2080 g2079) + ((lambda (g2081) + ((lambda (g2082) + (if (if g2082 + (apply + (lambda (g2084 + g2083) + (g2030 + g2084)) + g2082) + '#f) + (apply + (lambda (g2086 + g2085) + (g2079 + (map (lambda (g2087) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(quote? + x) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x + k) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(pat-x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2087)) + g2085))) + g2082) + ((lambda (g2088) + (if (if g2088 + (apply + (lambda (g2090 + g2089) + (g2022 + g2090)) + g2088) + '#f) + (apply + (lambda (g2092 + g2091) + (g2079 + g2091)) + g2088) + ((lambda (g2094) + (if (if g2094 + (apply + (lambda (g2097 + g2095 + g2096) + (g2029 + g2097)) + g2094) + '#f) + (apply + (lambda (g2100 + g2098 + g2099) + (g2078 + g2099 + (lambda (g2101) + (g2079 + (cons g2098 + g2101))))) + g2094) + ((lambda (g2102) + (list '#(syntax-object + list->vector + ((top) + #(ribcage + #(else) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(x + k) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(pat-x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2069)) + g2081))) + ($syntax-dispatch + g2081 + '(any any + any))))) + ($syntax-dispatch + g2081 + '(any . + each-any))))) + ($syntax-dispatch + g2081 + '(any each-any)))) + g2080)))) + g2078) + g2067 + (lambda (g2103) + (cons '#(syntax-object + vector + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(ls) + #((top)) + #("i")) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(pat-x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2103)))) + g2070))) + ($syntax-dispatch g2070 '(any each-any)))) + g2069)) + g2068)) + g2067))) + (g2026 + (lambda (g2105 g2104) + ((lambda (g2106) + ((lambda (g2107) + (if g2107 + (apply + (lambda (g2108) + (if (= g2104 '0) + g2108 + (g2024 + '(#(syntax-object + quote + ((top) + #(ribcage #(p) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + unquote + ((top) + #(ribcage #(p) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (g2026 (list g2108) (- g2104 '1))))) + g2107) + ((lambda (g2109) + (if g2109 + (apply + (lambda (g2111 g2110) + (if (= g2104 '0) + (g2028 g2111 (g2026 g2110 g2104)) + (g2024 + (g2024 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + unquote + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (g2026 g2111 (- g2104 '1))) + (g2026 g2110 g2104)))) + g2109) + ((lambda (g2114) + (if g2114 + (apply + (lambda (g2116 g2115) + (if (= g2104 '0) + (g2027 + g2116 + (g2026 g2115 g2104)) + (g2024 + (g2024 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + unquote-splicing + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + (g2026 + g2116 + (- g2104 '1))) + (g2026 g2115 g2104)))) + g2114) + ((lambda (g2119) + (if g2119 + (apply + (lambda (g2120) + (g2024 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + quasiquote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + (g2026 + (list g2120) + (+ g2104 '1)))) + g2119) + ((lambda (g2121) + (if g2121 + (apply + (lambda (g2123 g2122) + (g2024 + (g2026 + g2123 + g2104) + (g2026 + g2122 + g2104))) + g2121) + ((lambda (g2124) + (if g2124 + (apply + (lambda (g2125) + (g2025 + (g2026 + g2125 + g2104))) + g2124) + ((lambda (g2127) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(p + lev) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2127)) + g2106))) + ($syntax-dispatch + g2106 + '#(vector + each-any))))) + ($syntax-dispatch + g2106 + '(any . any))))) + ($syntax-dispatch + g2106 + '(#(free-id + #(syntax-object + quasiquote + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + any))))) + ($syntax-dispatch + g2106 + '((#(free-id + #(syntax-object + unquote-splicing + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + . + each-any) + . + any))))) + ($syntax-dispatch + g2106 + '((#(free-id + #(syntax-object + unquote + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + . + each-any) + . + any))))) + ($syntax-dispatch + g2106 + '(#(free-id + #(syntax-object + unquote + ((top) + #(ribcage () () ()) + #(ribcage #(p lev) #((top) (top)) #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ())))) + any)))) + g2105)))) + (lambda (g2031) + ((lambda (g2032) + ((lambda (g2033) + (if g2033 + (apply (lambda (g2035 g2034) (g2026 g2034 '0)) g2033) + (syntax-error g2032))) + ($syntax-dispatch g2032 '(any any)))) + g2031)))) +($sc-put-cte + 'include + (lambda (g2143) + (letrec ((g2144 + (lambda (g2155 g2154) + ((lambda (g2156) + ((letrec ((g2157 + (lambda () + ((lambda (g2158) + (if (eof-object? g2158) + (begin (close-input-port g2156) '()) + (cons (datum->syntax-object + g2154 + g2158) + (g2157)))) + (read g2156))))) + g2157))) + (open-input-file g2155))))) + ((lambda (g2145) + ((lambda (g2146) + (if g2146 + (apply + (lambda (g2148 g2147) + ((lambda (g2149) + ((lambda (g2150) + ((lambda (g2151) + (if g2151 + (apply + (lambda (g2152) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(exp) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(fn) + #((top)) + #("i")) + #(ribcage + #(k filename) + #((top) (top)) + #("i" "i")) + #(ribcage + (read-file) + ((top)) + ("i")) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2152)) + g2151) + (syntax-error g2150))) + ($syntax-dispatch g2150 'each-any))) + (g2144 g2149 g2148))) + (syntax-object->datum g2147))) + g2146) + (syntax-error g2145))) + ($syntax-dispatch g2145 '(any any)))) + g2143)))) +($sc-put-cte + 'unquote + (lambda (g2159) + ((lambda (g2160) + ((lambda (g2161) + (if g2161 + (apply + (lambda (g2163 g2162) + (syntax-error + g2159 + '"expression not valid outside of quasiquote")) + g2161) + (syntax-error g2160))) + ($syntax-dispatch g2160 '(any . each-any)))) + g2159))) +($sc-put-cte + 'unquote-splicing + (lambda (g2164) + ((lambda (g2165) + ((lambda (g2166) + (if g2166 + (apply + (lambda (g2168 g2167) + (syntax-error + g2164 + '"expression not valid outside of quasiquote")) + g2166) + (syntax-error g2165))) + ($syntax-dispatch g2165 '(any . each-any)))) + g2164))) +($sc-put-cte + 'case + (lambda (g2169) + ((lambda (g2170) + ((lambda (g2171) + (if g2171 + (apply + (lambda (g2175 g2172 g2174 g2173) + ((lambda (g2176) + ((lambda (g2203) + (list '#(syntax-object + let + ((top) + #(ribcage #(body) #((top)) #("i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(body) + #((top)) + #("i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2172)) + g2203)) + g2176)) + ((letrec ((g2177 + (lambda (g2179 g2178) + (if (null? g2178) + ((lambda (g2180) + ((lambda (g2181) + (if g2181 + (apply + (lambda (g2183 g2182) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 e2) + #((top) + (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2183 + g2182))) + g2181) + ((lambda (g2185) + (if g2185 + (apply + (lambda (g2188 + g2186 + g2187) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2188)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2186 + g2187)))) + g2185) + ((lambda (g2191) + (syntax-error + g2169)) + g2180))) + ($syntax-dispatch + g2180 + '(each-any + any + . + each-any))))) + ($syntax-dispatch + g2180 + '(#(free-id + #(syntax-object + else + ((top) + #(ribcage () () ()) + #(ribcage + #(clause clauses) + #((top) (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + any + . + each-any)))) + g2179) + ((lambda (g2192) + ((lambda (g2193) + ((lambda (g2194) + ((lambda (g2195) + (if g2195 + (apply + (lambda (g2198 + g2196 + g2197) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2198)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2196 + g2197)) + g2193)) + g2195) + ((lambda (g2201) + (syntax-error + g2169)) + g2194))) + ($syntax-dispatch + g2194 + '(each-any + any + . + each-any)))) + g2179)) + g2192)) + (g2177 (car g2178) (cdr g2178))))))) + g2177) + g2174 + g2173))) + g2171) + (syntax-error g2170))) + ($syntax-dispatch g2170 '(any any any . each-any)))) + g2169))) +($sc-put-cte + 'identifier-syntax + (lambda (g2204) + ((lambda (g2205) + ((lambda (g2206) + (if g2206 + (apply + (lambda (g2208 g2207) + (list '#(syntax-object + lambda + ((top) + #(ribcage #(_ e) #((top) (top)) #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ()))) + '(#(syntax-object + x + ((top) + #(ribcage #(_ e) #((top) (top)) #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ())))) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '() + (list '#(syntax-object + id + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '(#(syntax-object + identifier? + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + id + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2207)) + (list (cons g2208 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + ... + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g2207 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + ... + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))))))))) + g2206) + ((lambda (g2209) + (if (if g2209 + (apply + (lambda (g2215 g2210 g2214 g2211 g2213 g2212) + (if (identifier? g2210) + (identifier? g2211) + '#f)) + g2209) + '#f) + (apply + (lambda (g2221 g2216 g2220 g2217 g2219 g2218) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) (top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '(#(syntax-object + quote + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + macro! + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (list '#(syntax-object + lambda + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '(#(syntax-object + x + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '#(syntax-object + x + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '(#(syntax-object + set! + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (list (list '#(syntax-object + set! + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2217 + g2219) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2218)) + (list (cons g2216 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + ... + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2220 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + ... + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))))))) + (list g2216 + (list '#(syntax-object + identifier? + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2216)) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2220)))))) + g2209) + (syntax-error g2205))) + ($syntax-dispatch + g2205 + '(any (any any) + ((#(free-id + #(syntax-object + set! + ((top) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ())))) + any + any) + any)))))) + ($syntax-dispatch g2205 '(any any)))) + g2204))) diff --git a/module/language/r5rs/psyntax.scm b/module/language/r5rs/psyntax.scm new file mode 100644 index 000000000..b8c6a3edb --- /dev/null +++ b/module/language/r5rs/psyntax.scm @@ -0,0 +1 @@ +((lambda () (letrec ((g452 (lambda (g453) ((letrec ((g454 (lambda (g455 g456 g457) (if (pair? g455) (g454 (cdr g455) (cons (g393 (car g455) g457) g456) g457) (if (g256 g455) (cons (g393 g455 g457) g456) (if (null? g455) g456 (if (g204 g455) (g454 (g205 g455) g456 (g371 g457 (g206 g455))) (if (g90 g455) (g454 (annotation-expression g455) g456 g457) (cons g455 g456))))))))) g454) g453 (quote ()) (quote (()))))) (g451 (lambda (g458) ((lambda (g459) (if (g90 g459) (gensym) (gensym))) (if (g204 g458) (g205 g458) g458)))) (g450 (lambda (g460 g461) (g449 g460 g461 (lambda (g462) (if ((lambda (g463) (if g463 g463 (if (pair? g462) (g90 (car g462)) (quote #f)))) (g90 g462)) (g448 g462 (quote #f)) g462))))) (g449 (lambda (g464 g465 g466) (if (memq (quote top) (g264 g465)) (g466 g464) ((letrec ((g467 (lambda (g468) (if (g204 g468) (g449 (g205 g468) (g206 g468) g466) (if (pair? g468) ((lambda (g469 g470) (if (if (eq? g469 (car g468)) (eq? g470 (cdr g468)) (quote #f)) g468 (cons g469 g470))) (g467 (car g468)) (g467 (cdr g468))) (if (vector? g468) ((lambda (g471) ((lambda (g472) (if (andmap eq? g471 g472) g468 (list->vector g472))) (map g467 g471))) (vector->list g468)) g468)))))) g467) g464)))) (g448 (lambda (g473 g474) (if (pair? g473) ((lambda (g475) (begin (if g474 (set-annotation-stripped! g474 g475) (void)) (set-car! g475 (g448 (car g473) (quote #f))) (set-cdr! g475 (g448 (cdr g473) (quote #f))) g475)) (cons (quote #f) (quote #f))) (if (g90 g473) ((lambda (g476) (if g476 g476 (g448 (annotation-expression g473) g473))) (annotation-stripped g473)) (if (vector? g473) ((lambda (g477) (begin (if g474 (set-annotation-stripped! g474 g477) (void)) ((letrec ((g478 (lambda (g479) (if (not (< g479 (quote 0))) (begin (vector-set! g477 g479 (g448 (vector-ref g473 g479) (quote #f))) (g478 (- g479 (quote 1)))) (void))))) g478) (- (vector-length g473) (quote 1))) g477)) (make-vector (vector-length g473))) g473))))) (g447 (lambda (g480) (if (g255 g480) (g378 g480 (quote #(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*)) () ()))))) (quote #f)))) (g446 (lambda () (list (quote void)))) (g445 (lambda (g481 g482 g483 g484 g485 g486) ((lambda (g487) ((lambda (g488) (if g488 (apply (lambda (g489 g490 g491 g492 g493) ((lambda (g494) (if (not (g389 g494)) (g391 (map (lambda (g495) (g393 g495 g484)) g494) (g394 g482 g484 g485) (quote "keyword")) ((lambda (g496) ((lambda (g497) (g486 (cons g492 g493) (g247 g496 ((lambda (g499 g500) (map (lambda (g501) (g231 (quote deferred) (g432 g501 g500 g499))) g491)) (if g481 g497 g484) (g249 g483)) g483) g497 g485)) (g368 g494 g496 g484))) (g299 g494)))) g490)) g488) ((lambda (g504) (syntax-error (g394 g482 g484 g485))) g487))) ($syntax-dispatch g487 (quote (any #(each (any any)) any . each-any))))) g482))) (g444 (lambda (g505 g506 g507 g508 g509) ((lambda (g510) ((lambda (g511) (if g511 (apply (lambda (g512 g513 g514) ((lambda (g515) (if (not (g389 g515)) (syntax-error g505 (quote "invalid parameter list in")) ((lambda (g516 g517) (g509 g517 (g437 (cons g513 g514) g505 (g248 g516 g517 g507) (g368 g515 g516 g508)))) (g299 g515) (map g451 g515)))) g512)) g511) ((lambda (g520) (if g520 (apply (lambda (g521 g522 g523) ((lambda (g524) (if (not (g389 g524)) (syntax-error g505 (quote "invalid parameter list in")) ((lambda (g525 g526) (g509 ((letrec ((g527 (lambda (g528 g529) (if (null? g528) g529 (g527 (cdr g528) (cons (car g528) g529)))))) g527) (cdr g526) (car g526)) (g437 (cons g522 g523) g505 (g248 g525 g526 g507) (g368 g524 g525 g508)))) (g299 g524) (map g451 g524)))) (g452 g521))) g520) ((lambda (g531) (syntax-error g505)) g510))) ($syntax-dispatch g510 (quote (any any . each-any)))))) ($syntax-dispatch g510 (quote (each-any any . each-any))))) g506))) (g443 (lambda (g532 g533 g534 g535) ((lambda (g536) ((lambda (g537) (if (if g537 (apply (lambda (g538 g539 g540) (g256 g539)) g537) (quote #f)) (apply (lambda (g541 g542 g543) (g535 g542 g543 g533)) g537) ((lambda (g544) (syntax-error (g394 g532 g533 g534))) g536))) ($syntax-dispatch g536 (quote (any any any))))) g532))) (g442 (lambda (g545 g546 g547 g548) ((lambda (g549) ((lambda (g550) (if (if g550 (apply (lambda (g551 g552 g553) (g256 g552)) g550) (quote #f)) (apply (lambda (g554 g555 g556) (g548 g555 g556 g546)) g550) ((lambda (g557) (if (if g557 (apply (lambda (g558 g559 g560 g561 g562) (if (g256 g559) (g389 (g452 g560)) (quote #f))) g557) (quote #f)) (apply (lambda (g563 g564 g565 g566 g567) (g548 (g393 g564 g546) (cons (quote #(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 g565 (cons g566 g567)) g546)) (quote (())))) g557) ((lambda (g569) (if (if g569 (apply (lambda (g570 g571) (g256 g571)) g569) (quote #f)) (apply (lambda (g572 g573) (g548 (g393 g573 g546) (quote (#(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*)) () ()))))) (quote (())))) g569) ((lambda (g574) (syntax-error (g394 g545 g546 g547))) g549))) ($syntax-dispatch g549 (quote (any any)))))) ($syntax-dispatch g549 (quote (any (any . any) any . each-any)))))) ($syntax-dispatch g549 (quote (any any any))))) g545))) (g441 (lambda (g575 g576 g577 g578) ((lambda (g579) ((lambda (g580) (if (if g580 (apply (lambda (g581 g582) (g256 g582)) g580) (quote #f)) (apply (lambda (g583 g584) (g578 (g393 g584 g576))) g580) ((lambda (g585) (syntax-error (g394 g575 g576 g577))) g579))) ($syntax-dispatch g579 (quote (any any))))) g575))) (g440 (lambda (g586 g587 g588 g589 g590) (letrec ((g592 (lambda (g593 g594 g595) (g590 g593 (g591 g594) (map (lambda (g596) (g393 g596 g589)) g595)))) (g591 (lambda (g597) (if (null? g597) (quote ()) (cons ((lambda (g598) ((lambda (g599) (if g599 (apply (lambda (g600) (g591 g600)) g599) ((lambda (g602) (if (g256 g602) (g393 g602 g589) (syntax-error (g394 g586 g587 g588) (quote "invalid exports list in")))) g598))) ($syntax-dispatch g598 (quote each-any)))) (car g597)) (g591 (cdr g597))))))) ((lambda (g603) ((lambda (g604) (if g604 (apply (lambda (g605 g606 g607) (g592 (quote #f) g606 g607)) g604) ((lambda (g610) (if (if g610 (apply (lambda (g611 g612 g613 g614) (g256 g612)) g610) (quote #f)) (apply (lambda (g615 g616 g617 g618) (g592 (g393 g616 g587) g617 g618)) g610) ((lambda (g621) (syntax-error (g394 g586 g587 g588))) g603))) ($syntax-dispatch g603 (quote (any any each-any . each-any)))))) ($syntax-dispatch g603 (quote (any each-any . each-any))))) g586)))) (g439 (lambda (g622 g623) ((lambda (g624) (if g624 (g366 g623 g624) (g429 (lambda (g625) ((lambda (g626) (begin (if (not g626) (syntax-error g625 (quote "exported identifier not visible")) (void)) (g363 g623 g625 g626))) (g376 g625 (quote (()))))) (g404 g622)))) (g405 g622)))) (g438 (lambda (g627 g628 g629 g630 g631) (letrec ((g632 (lambda (g633 g634 g635 g636 g637) (begin (g426 g628 g634) (g631 g633 g634 g635 g636 g637))))) ((letrec ((g638 (lambda (g639 g640 g641 g642 g643) (if (null? g639) (g632 g639 g640 g641 g642 g643) ((lambda (g644 g645) (call-with-values (lambda () (g398 g644 g645 (quote (())) (quote #f) g627)) (lambda (g646 g647 g648 g649 g650) ((lambda (g651) (if (memv g651 (quote (define-form))) (g442 g648 g649 g650 (lambda (g652 g653 g654) ((lambda (g655 g656) ((lambda (g657) (begin (g363 g627 g655 g656) (g424 g630 g656 (g231 (quote lexical) g657)) (g638 (cdr g639) (cons g655 g640) (cons g657 g641) (cons (cons g645 (g393 g653 g654)) g642) g643))) (g451 g655))) (g393 g652 g654) (g297)))) (if (memv g651 (quote (define-syntax-form))) (g443 g648 g649 g650 (lambda (g658 g659 g660) ((lambda (g661 g662 g663) (begin (g363 g627 g661 g662) (g424 g630 g662 (g231 (quote deferred) g663)) (g638 (cdr g639) (cons g661 g640) g641 g642 g643))) (g393 g658 g660) (g297) (g432 g659 (g249 g645) g660)))) (if (memv g651 (quote (module-form))) ((lambda (g664) ((lambda (g665) ((lambda () (g440 g648 g649 g650 g665 (lambda (g666 g667 g668) (g438 g664 (g394 g648 g649 g650) (map (lambda (g669) (cons g645 g669)) g668) g630 (lambda (g670 g671 g672 g673 g674) (begin (g425 g628 (g401 g667) g671) ((lambda (g675 g676 g677 g678) (if g666 ((lambda (g679) (begin (g363 g627 g666 g679) (g424 g630 g679 (g231 (quote module) g675)) (g638 (cdr g639) (cons g666 g640) g676 g677 g678))) (g297)) ((lambda () (begin (g439 g675 g627) (g638 (cdr g639) (cons g675 g640) g676 g677 g678)))))) (g408 g667) (append g672 g641) (append g673 g642) (append g643 g674 g670)))))))))) (g263 (g264 g649) (cons g664 (g265 g649))))) (g304 (quote ()) (quote ()) (quote ()))) (if (memv g651 (quote (import-form))) (g441 g648 g649 g650 (lambda (g680) ((lambda (g681) ((lambda (g682) ((lambda (g683) (if (memv g683 (quote (module))) ((lambda (g684) (begin (if g647 (g364 g627 g647) (void)) (g439 g684 g627) (g638 (cdr g639) (cons g684 g640) g641 g642 g643))) (cdr g682)) (if (memv g683 (quote (displaced-lexical))) (g250 g680) (syntax-error g680 (quote "import from unknown module"))))) (car g682))) (g253 g681 g630))) (g377 g680 (quote (())))))) (if (memv g651 (quote (begin-form))) ((lambda (g685) ((lambda (g686) (if g686 (apply (lambda (g687 g688) (g638 ((letrec ((g689 (lambda (g690) (if (null? g690) (cdr g639) (cons (cons g645 (g393 (car g690) g649)) (g689 (cdr g690))))))) g689) g688) g640 g641 g642 g643)) g686) (syntax-error g685))) ($syntax-dispatch g685 (quote (any . each-any))))) g648) (if (memv g651 (quote (local-syntax-form))) (g445 g647 g648 g645 g649 g650 (lambda (g692 g693 g694 g695) (g638 ((letrec ((g696 (lambda (g697) (if (null? g697) (cdr g639) (cons (cons g693 (g393 (car g697) g694)) (g696 (cdr g697))))))) g696) g692) g640 g641 g642 g643))) (g632 (cons (cons g645 (g394 g648 g649 g650)) (cdr g639)) g640 g641 g642 g643)))))))) g646)))) (cdar g639) (caar g639)))))) g638) g629 (quote ()) (quote ()) (quote ()) (quote ()))))) (g437 (lambda (g698 g699 g700 g701) ((lambda (g702) ((lambda (g703) ((lambda (g704) ((lambda (g705) ((lambda () (g438 g703 g699 g705 g702 (lambda (g706 g707 g708 g709 g710) (begin (if (null? g706) (syntax-error g699 (quote "no expressions in body")) (void)) (g191 (quote #f) g708 (map (lambda (g711) (g432 (cdr g711) (car g711) (quote (())))) g709) (g190 (quote #f) (map (lambda (g712) (g432 (cdr g712) (car g712) (quote (())))) (append g710 g706)))))))))) (map (lambda (g713) (cons g702 (g393 g713 g704))) g698))) (g263 (g264 g701) (cons g703 (g265 g701))))) (g304 (quote ()) (quote ()) (quote ())))) (cons (quote ("placeholder" placeholder)) g700)))) (g436 (lambda (g714 g715 g716 g717 g718 g719) (letrec ((g720 (lambda (g721 g722) (if (pair? g721) (cons (g720 (car g721) g722) (g720 (cdr g721) g722)) (if (g204 g721) ((lambda (g723) ((lambda (g724 g725) (g203 (g205 g721) (if (if (pair? g724) (eq? (car g724) (quote #f)) (quote #f)) (g263 (cdr g724) (if g719 (cons g719 (cdr g725)) (cdr g725))) (g263 (cons g722 g724) (if g719 (cons g719 (cons (quote shift) g725)) (cons (quote shift) g725)))))) (g264 g723) (g265 g723))) (g206 g721)) (if (vector? g721) ((lambda (g726) ((lambda (g727) ((lambda () ((letrec ((g728 (lambda (g729) (if (= g729 g726) g727 (begin (vector-set! g727 g729 (g720 (vector-ref g721 g729) g722)) (g728 (+ g729 (quote 1)))))))) g728) (quote 0))))) (make-vector g726))) (vector-length g721)) (if (symbol? g721) (syntax-error (g394 g715 g717 g718) (quote "encountered raw symbol ") (format (quote "~s") g721) (quote " in output of macro")) g721))))))) (g720 ((lambda (g730) (if (procedure? g730) (g730 (lambda (g731) (begin (if (not (identifier? g731)) (syntax-error g731 (quote "environment argument is not an identifier")) (void)) (g253 (g377 g731 (quote (()))) g716)))) g730)) (g714 (g394 g715 (g349 g717) g718))) (string (quote #\m)))))) (g435 (lambda (g732 g733 g734 g735 g736) ((lambda (g737) ((lambda (g738) (if (if g738 (apply (lambda (g739 g740 g741) (g256 g740)) g738) (quote #f)) (apply (lambda (g742 g743 g744) ((lambda (g745) ((lambda (g746) ((lambda (g747) (if (memv g747 (quote (macro!))) ((lambda (g748 g749) (g398 (g436 (g233 g746) (list (quote #(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*)) () ())))) g748 g749) g733 (quote (())) g735 g736) g733 (quote (())) g735 g736)) (g393 g743 g734) (g393 g744 g734)) (values (quote core) (lambda (g750 g751 g752 g753) ((lambda (g754 g755) ((lambda (g756) ((lambda (g757) (if (memv g757 (quote (lexical))) (list (quote set!) (g233 g756) g754) (if (memv g757 (quote (global))) (list (quote set!) (g233 g756) g754) (if (memv g757 (quote (displaced-lexical))) (syntax-error (g393 g743 g752) (quote "identifier out of context")) (syntax-error (g394 g750 g752 g753)))))) (g232 g756))) (g253 g755 g751))) (g432 g744 g751 g752) (g377 g743 g752))) g732 g734 g735))) (g232 g746))) (g253 g745 g733))) (g377 g743 g734))) g738) ((lambda (g758) (syntax-error (g394 g732 g734 g735))) g737))) ($syntax-dispatch g737 (quote (any any any))))) g732))) (g434 (lambda (g759 g760 g761 g762 g763) ((lambda (g764) ((lambda (g765) (if g765 (apply (lambda (g766 g767) (cons g759 (map (lambda (g768) (g432 g768 g761 g762)) g767))) g765) ((lambda (g770) (syntax-error (g394 g760 g762 g763))) g764))) ($syntax-dispatch g764 (quote (any . each-any))))) g760))) (g433 (lambda (g771 g772 g773 g774 g775 g776) ((lambda (g777) (if (memv g777 (quote (lexical))) g772 (if (memv g777 (quote (core))) (g772 g773 g774 g775 g776) (if (memv g777 (quote (lexical-call))) (g434 g772 g773 g774 g775 g776) (if (memv g777 (quote (constant))) (list (quote quote) (g450 (g394 g773 g775 g776) (quote (())))) (if (memv g777 (quote (global))) g772 (if (memv g777 (quote (call))) (g434 (g432 (car g773) g774 g775) g773 g774 g775 g776) (if (memv g777 (quote (begin-form))) ((lambda (g778) ((lambda (g779) (if g779 (apply (lambda (g780 g781 g782) (g395 (cons g781 g782) g774 g775 g776)) g779) (syntax-error g778))) ($syntax-dispatch g778 (quote (any any . each-any))))) g773) (if (memv g777 (quote (local-syntax-form))) (g445 g772 g773 g774 g775 g776 g395) (if (memv g777 (quote (eval-when-form))) ((lambda (g784) ((lambda (g785) (if g785 (apply (lambda (g786 g787 g788 g789) ((lambda (g790) (if (memq (quote eval) g790) (g395 (cons g788 g789) g774 g775 g776) (g446))) (g397 g773 g787 g775))) g785) (syntax-error g784))) ($syntax-dispatch g784 (quote (any each-any any . each-any))))) g773) (if (memv g777 (quote (define-form define-syntax-form module-form import-form))) (syntax-error (g394 g773 g775 g776) (quote "invalid context for definition")) (if (memv g777 (quote (syntax))) (syntax-error (g394 g773 g775 g776) (quote "reference to pattern variable outside syntax form")) (if (memv g777 (quote (displaced-lexical))) (g250 (g394 g773 g775 g776)) (syntax-error (g394 g773 g775 g776))))))))))))))) g771))) (g432 (lambda (g793 g794 g795) (call-with-values (lambda () (g398 g793 g794 g795 (quote #f) (quote #f))) (lambda (g796 g797 g798 g799 g800) (g433 g796 g797 g798 g794 g799 g800))))) (g431 (lambda (g801 g802 g803) ((lambda (g804) (if (memv g804 (quote (c))) (if (memq (quote compile) g802) ((lambda (g805) (begin (g91 g805) (if (memq (quote load) g802) g805 (g446)))) (g803)) (if (memq (quote load) g802) (g803) (g446))) (if (memv g804 (quote (c&e))) ((lambda (g806) (begin (g91 g806) g806)) (g803)) (begin (if (memq (quote eval) g802) (g91 (g803)) (void)) (g446))))) g801))) (g430 (lambda (g807 g808) (list (quote $sc-put-cte) (list (quote quote) g807) (list (quote quote) (g231 (quote do-import) g808))))) (g429 (lambda (g809 g810) ((lambda (g811) ((letrec ((g812 (lambda (g813) (if (not (= g813 g811)) (begin (g809 (vector-ref g810 g813)) (g812 (+ g813 (quote 1)))) (void))))) g812) (quote 0))) (vector-length g810)))) (g428 (lambda (g814 g815) ((letrec ((g816 (lambda (g817 g818) (if (< g817 (quote 0)) g818 (g816 (- g817 (quote 1)) (cons (g814 (vector-ref g815 g817)) g818)))))) g816) (- (vector-length g815) (quote 1)) (quote ())))) (g427 (lambda (g819 g820 g821 g822 g823 g824 g825 g826 g827) (letrec ((g830 (lambda (g831 g832) ((lambda (g833) (map (lambda (g834) ((lambda (g835) (if (not (g392 g835 g833)) g834 (g410 (g412 g834) g835 (g414 g834) (append (g829 g835) (g415 g834)) (g416 g834)))) (g413 g834))) g831)) (map (lambda (g836) (if (pair? g836) (car g836) g836)) g832)))) (g829 (lambda (g837) ((letrec ((g838 (lambda (g839) (if (null? g839) (quote ()) (if (if (pair? (car g839)) (g388 g837 (caar g839)) (quote #f)) (g401 (cdar g839)) (g838 (cdr g839))))))) g838) g823))) (g828 (lambda (g840 g841 g842) (begin (g426 g820 g841) (g425 g820 g824 g841) (g827 g840 g842))))) ((letrec ((g843 (lambda (g844 g845 g846 g847) (if (null? g844) (g828 g846 g845 g847) ((lambda (g848 g849) (call-with-values (lambda () (g398 g848 g849 (quote (())) (quote #f) g819)) (lambda (g850 g851 g852 g853 g854) ((lambda (g855) (if (memv g855 (quote (define-form))) (g442 g852 g853 g854 (lambda (g856 g857 g858) ((lambda (g859) ((lambda (g860) ((lambda (g861) ((lambda () (begin (g363 g819 g859 g860) (g843 (cdr g844) (cons g859 g845) (cons (g410 g850 g859 g860 g861 (cons g849 (g393 g857 g858))) g846) g847))))) (g829 g859))) (g300))) (g393 g856 g858)))) (if (memv g855 (quote (define-syntax-form))) (g443 g852 g853 g854 (lambda (g862 g863 g864) ((lambda (g865) ((lambda (g866) ((lambda (g867) ((lambda (g868) ((lambda () (begin (g424 g822 (g302 g866) (cons (quote deferred) g868)) (g363 g819 g865 g866) (g843 (cdr g844) (cons g865 g845) (cons (g410 g850 g865 g866 g867 g868) g846) g847))))) (g432 g863 (g249 g849) g864))) (g829 g865))) (g300))) (g393 g862 g864)))) (if (memv g855 (quote (module-form))) ((lambda (g869) ((lambda (g870) ((lambda () (g440 g852 g853 g854 g870 (lambda (g871 g872 g873) (g427 g869 (g394 g852 g853 g854) (map (lambda (g874) (cons g849 g874)) g873) g822 g872 (g401 g872) g825 g826 (lambda (g875 g876) ((lambda (g877) ((lambda (g878) ((lambda (g879) ((lambda () (if g871 ((lambda (g880 g881) (begin (g424 g822 (g302 g880) (g231 (quote module) g877)) (g363 g819 g871 g880) (g843 (cdr g844) (cons g871 g845) (cons (g410 g850 g871 g880 g881 g872) g878) g879))) (g300) (g829 g871)) ((lambda () (begin (g439 g877 g819) (g843 (cdr g844) (cons g877 g845) g878 g879)))))))) (append g847 g876))) (append (if g871 g875 (g830 g875 g872)) g846))) (g408 g872))))))))) (g263 (g264 g853) (cons g869 (g265 g853))))) (g304 (quote ()) (quote ()) (quote ()))) (if (memv g855 (quote (import-form))) (g441 g852 g853 g854 (lambda (g882) ((lambda (g883) ((lambda (g884) ((lambda (g885) (if (memv g885 (quote (module))) ((lambda (g886) (begin (if g851 (g364 g819 g851) (void)) (g439 g886 g819) (g843 (cdr g844) (cons g886 g845) (g830 g846 (vector->list (g404 g886))) g847))) (g233 g884)) (if (memv g885 (quote (displaced-lexical))) (g250 g882) (syntax-error g882 (quote "import from unknown module"))))) (g232 g884))) (g253 g883 g822))) (g377 g882 (quote (())))))) (if (memv g855 (quote (begin-form))) ((lambda (g887) ((lambda (g888) (if g888 (apply (lambda (g889 g890) (g843 ((letrec ((g891 (lambda (g892) (if (null? g892) (cdr g844) (cons (cons g849 (g393 (car g892) g853)) (g891 (cdr g892))))))) g891) g890) g845 g846 g847)) g888) (syntax-error g887))) ($syntax-dispatch g887 (quote (any . each-any))))) g852) (if (memv g855 (quote (local-syntax-form))) (g445 g851 g852 g849 g853 g854 (lambda (g894 g895 g896 g897) (g843 ((letrec ((g898 (lambda (g899) (if (null? g899) (cdr g844) (cons (cons g895 (g393 (car g899) g896)) (g898 (cdr g899))))))) g898) g894) g845 g846 g847))) (g828 g846 g845 (append g847 (cons (cons g849 (g394 g852 g853 g854)) (cdr g844))))))))))) g850)))) (cdar g844) (caar g844)))))) g843) g821 (quote ()) (quote ()) (quote ()))))) (g426 (lambda (g900 g901) (letrec ((g905 (lambda (g906 g907 g908) ((lambda (g909) (if g909 (if (g367 ((lambda (g910) ((lambda (g911) (if (g90 g911) (annotation-expression g911) g911)) (if (g204 g910) (g205 g910) g910))) g906) g909 (if (symbol? g906) (g264 (quote ((top)))) (g264 (g206 g906)))) (cons g906 g908) g908) (g903 (g404 g907) (lambda (g912 g913) (if (g902 g912 g906) (cons g912 g913) g913)) g908))) (g405 g907)))) (g904 (lambda (g914 g915 g916) (if (g403 g914) (if (g403 g915) (call-with-values (lambda () ((lambda (g917 g918) (if (fx> (vector-length g917) (vector-length g918)) (values g914 g918) (values g915 g917))) (g404 g914) (g404 g915))) (lambda (g919 g920) (g903 g920 (lambda (g921 g922) (g905 g921 g919 g922)) g916))) (g905 g915 g914 g916)) (if (g403 g915) (g905 g914 g915 g916) (if (g902 g914 g915) (cons g914 g916) g916))))) (g903 (lambda (g923 g924 g925) ((lambda (g926) ((letrec ((g927 (lambda (g928 g929) (if (= g928 g926) g929 (g927 (+ g928 (quote 1)) (g924 (vector-ref g923 g928) g929)))))) g927) (quote 0) g925)) (vector-length g923)))) (g902 (lambda (g930 g931) (if (symbol? g930) (if (symbol? g931) (eq? g930 g931) (if (eq? g930 ((lambda (g932) ((lambda (g933) (if (g90 g933) (annotation-expression g933) g933)) (if (g204 g932) (g205 g932) g932))) g931)) (g373 (g264 (g206 g931)) (g264 (quote ((top))))) (quote #f))) (if (symbol? g931) (if (eq? g931 ((lambda (g934) ((lambda (g935) (if (g90 g935) (annotation-expression g935) g935)) (if (g204 g934) (g205 g934) g934))) g930)) (g373 (g264 (g206 g930)) (g264 (quote ((top))))) (quote #f)) (g388 g930 g931)))))) (if (not (null? g901)) ((letrec ((g936 (lambda (g937 g938 g939) (if (null? g938) (if (not (null? g939)) ((lambda (g940) (syntax-error g900 (quote "duplicate definition for ") (symbol->string (car g940)) (quote " in"))) (syntax-object->datum g939)) (void)) ((letrec ((g941 (lambda (g942 g943) (if (null? g942) (g936 (car g938) (cdr g938) g943) (g941 (cdr g942) (g904 g937 (car g942) g943)))))) g941) g938 g939))))) g936) (car g901) (cdr g901) (quote ())) (void))))) (g425 (lambda (g944 g945 g946) (letrec ((g947 (lambda (g948 g949) (ormap (lambda (g950) (if (g403 g950) ((lambda (g951) (if g951 (g367 ((lambda (g952) ((lambda (g953) (if (g90 g953) (annotation-expression g953) g953)) (if (g204 g952) (g205 g952) g952))) g948) g951 (g264 (g206 g948))) ((lambda (g954) ((letrec ((g955 (lambda (g956) (if (fx>= g956 (quote 0)) ((lambda (g957) (if g957 g957 (g955 (- g956 (quote 1))))) (g388 g948 (vector-ref g954 g956))) (quote #f))))) g955) (- (vector-length g954) (quote 1)))) (g404 g950)))) (g405 g950)) (g388 g948 g950))) g949)))) ((letrec ((g958 (lambda (g959 g960) (if (null? g959) (if (not (null? g960)) (syntax-error g960 (quote "missing definition for export(s)")) (void)) ((lambda (g961 g962) (if (g947 g961 g946) (g958 g962 g960) (g958 g962 (cons g961 g960)))) (car g959) (cdr g959)))))) g958) g945 (quote ()))))) (g424 (lambda (g963 g964 g965) (set-cdr! g963 (g246 g964 g965 (cdr g963))))) (g423 (lambda (g966 g967) (if (null? g966) (quote ()) (if (g392 (car g966) g967) (g423 (cdr g966) g967) (cons (car g966) (g423 (cdr g966) g967)))))) (g422 (lambda (g968 g969 g970 g971 g972 g973 g974 g975 g976 g977) ((lambda (g978) (g427 g970 (g394 g968 g971 g972) (map (lambda (g979) (cons g969 g979)) g977) g969 g976 g978 g973 g974 (lambda (g980 g981) ((letrec ((g982 (lambda (g983 g984 g985 g986 g987) (if (null? g983) ((letrec ((g988 (lambda (g989 g990 g991) (if (null? g989) ((lambda (g992 g993 g994) (begin (for-each (lambda (g995) (apply (lambda (g996 g997 g998 g999) (if g997 (g303 g997 g998) (void))) g995)) g987) (g190 (quote #f) (list (g431 g973 g974 (lambda () (if (null? g987) (g446) (g190 (quote #f) (map (lambda (g1000) (apply (lambda (g1001 g1002 g1003 g1004) (list (quote $sc-put-cte) (list (quote quote) g1003) (if (eq? g1001 (quote define-syntax-form)) g1004 (list (quote quote) (g231 (quote module) (g409 g1004 g1003)))))) g1000)) g987))))) (g431 g973 g974 (lambda () ((lambda (g1005) ((lambda (g1006) ((lambda (g1007) ((lambda () (if g1005 (list (quote $sc-put-cte) (list (quote quote) (if (g373 (g264 (g206 g975)) (g264 (quote ((top))))) g1005 ((lambda (g1008) (g203 g1005 (g263 g1008 (list (g304 (vector g1005) (vector g1008) (vector (g101 g1005))))))) (g264 (g206 g975))))) g1007) ((lambda (g1009) (g190 (quote #f) (list (list (quote $sc-put-cte) (list (quote quote) g1009) g1007) (g430 g1009 g1006)))) (g101 (quote tmp))))))) (list (quote quote) (g231 (quote module) (g409 g976 g1006))))) (g101 g1005))) (if g975 ((lambda (g1010) ((lambda (g1011) (if (g90 g1011) (annotation-expression g1011) g1011)) (if (g204 g1010) (g205 g1010) g1010))) g975) (quote #f))))) (g190 (quote #f) (map (lambda (g1012) (list (quote define) g1012 (g446))) g985)) (g191 (quote #f) g990 g993 (g190 (quote #f) (list (if (null? g985) (g446) (g190 (quote #f) (map (lambda (g1013 g1014) (list (quote set!) g1013 g1014)) g985 g992))) (if (null? g994) (g446) (g190 (quote #f) g994))))) (g446))))) (map (lambda (g1015) (g432 (cdr g1015) (car g1015) (quote (())))) g986) (map (lambda (g1016) (g432 (cdr g1016) (car g1016) (quote (())))) g991) (map (lambda (g1017) (g432 (cdr g1017) (car g1017) (quote (())))) g981)) ((lambda (g1018) ((lambda (g1019) (if (memv g1019 (quote (define-form))) ((lambda (g1020) (begin (g424 g969 (g302 (g414 g1018)) (g231 (quote lexical) g1020)) (g988 (cdr g989) (cons g1020 g990) (cons (g416 g1018) g991)))) (g451 (g413 g1018))) (if (memv g1019 (quote (define-syntax-form module-form))) (g988 (cdr g989) g990 g991) (error (quote sc-expand-internal) (quote "unexpected module binding type"))))) (g412 g1018))) (car g989)))))) g988) g984 (quote ()) (quote ())) ((lambda (g1021 g1022) (letrec ((g1023 (lambda (g1024 g1025 g1026 g1027) ((letrec ((g1028 (lambda (g1029 g1030) (if (null? g1029) (g1027) (if (g388 (g413 (car g1029)) g1024) (g1026 (car g1029) (g370 (reverse g1030) (cdr g1029))) (g1028 (cdr g1029) (cons (car g1029) g1030))))))) g1028) g1025 (quote ()))))) (g1023 g1021 g984 (lambda (g1031 g1032) ((lambda (g1033 g1034 g1035) ((lambda (g1036 g1037) ((lambda (g1038) (if (memv g1038 (quote (define-form))) (begin (g303 g1034 g1037) (g982 g1036 g1032 (cons g1037 g985) (cons (g416 g1031) g986) g987)) (if (memv g1038 (quote (define-syntax-form))) (g982 g1036 g1032 g985 g986 (cons (list g1033 g1034 g1037 (g416 g1031)) g987)) (if (memv g1038 (quote (module-form))) ((lambda (g1039) (g982 (append (g401 g1039) g1036) g1032 g985 g986 (cons (list g1033 g1034 g1037 g1039) g987))) (g416 g1031)) (error (quote sc-expand-internal) (quote "unexpected module binding type")))))) g1033)) (append g1035 g1022) (g101 ((lambda (g1040) ((lambda (g1041) (if (g90 g1041) (annotation-expression g1041) g1041)) (if (g204 g1040) (g205 g1040) g1040))) g1021)))) (g412 g1031) (g414 g1031) (g415 g1031))) (lambda () (g982 g1022 g984 g985 g986 g987))))) (car g983) (cdr g983)))))) g982) g978 g980 (quote ()) (quote ()) (quote ()))))) (g401 g976)))) (g421 (lambda (g1042 g1043) (vector-set! g1042 (quote 5) g1043))) (g420 (lambda (g1044 g1045) (vector-set! g1044 (quote 4) g1045))) (g419 (lambda (g1046 g1047) (vector-set! g1046 (quote 3) g1047))) (g418 (lambda (g1048 g1049) (vector-set! g1048 (quote 2) g1049))) (g417 (lambda (g1050 g1051) (vector-set! g1050 (quote 1) g1051))) (g416 (lambda (g1052) (vector-ref g1052 (quote 5)))) (g415 (lambda (g1053) (vector-ref g1053 (quote 4)))) (g414 (lambda (g1054) (vector-ref g1054 (quote 3)))) (g413 (lambda (g1055) (vector-ref g1055 (quote 2)))) (g412 (lambda (g1056) (vector-ref g1056 (quote 1)))) (g411 (lambda (g1057) (if (vector? g1057) (if (= (vector-length g1057) (quote 6)) (eq? (vector-ref g1057 (quote 0)) (quote module-binding)) (quote #f)) (quote #f)))) (g410 (lambda (g1058 g1059 g1060 g1061 g1062) (vector (quote module-binding) g1058 g1059 g1060 g1061 g1062))) (g409 (lambda (g1063 g1064) (g402 (list->vector (map (lambda (g1065) (g369 (if (pair? g1065) (car g1065) g1065))) g1063)) g1064))) (g408 (lambda (g1066) (g402 (list->vector (map (lambda (g1067) (if (pair? g1067) (car g1067) g1067)) g1066)) (quote #f)))) (g407 (lambda (g1068 g1069) (vector-set! g1068 (quote 2) g1069))) (g406 (lambda (g1070 g1071) (vector-set! g1070 (quote 1) g1071))) (g405 (lambda (g1072) (vector-ref g1072 (quote 2)))) (g404 (lambda (g1073) (vector-ref g1073 (quote 1)))) (g403 (lambda (g1074) (if (vector? g1074) (if (= (vector-length g1074) (quote 3)) (eq? (vector-ref g1074 (quote 0)) (quote interface)) (quote #f)) (quote #f)))) (g402 (lambda (g1075 g1076) (vector (quote interface) g1075 g1076))) (g401 (lambda (g1077) ((letrec ((g1078 (lambda (g1079 g1080) (if (null? g1079) g1080 (g1078 (cdr g1079) (if (pair? (car g1079)) (g1078 (car g1079) g1080) (cons (car g1079) g1080))))))) g1078) g1077 (quote ())))) (g400 (lambda (g1081 g1082 g1083 g1084 g1085 g1086) (call-with-values (lambda () (g398 g1081 g1082 g1083 (quote #f) g1086)) (lambda (g1093 g1094 g1095 g1096 g1097) ((lambda (g1098) (if (memv g1098 (quote (begin-form))) ((lambda (g1099) ((lambda (g1100) (if g1100 (apply (lambda (g1101) (g446)) g1100) ((lambda (g1102) (if g1102 (apply (lambda (g1103 g1104 g1105) (g396 (cons g1104 g1105) g1082 g1096 g1097 g1084 g1085 g1086)) g1102) (syntax-error g1099))) ($syntax-dispatch g1099 (quote (any any . each-any)))))) ($syntax-dispatch g1099 (quote (any))))) g1095) (if (memv g1098 (quote (local-syntax-form))) (g445 g1094 g1095 g1082 g1096 g1097 (lambda (g1107 g1108 g1109 g1110) (g396 g1107 g1108 g1109 g1110 g1084 g1085 g1086))) (if (memv g1098 (quote (eval-when-form))) ((lambda (g1111) ((lambda (g1112) (if g1112 (apply (lambda (g1113 g1114 g1115 g1116) ((lambda (g1117 g1118) (if (eq? g1084 (quote e)) (if (memq (quote eval) g1117) (g396 g1118 g1082 g1096 g1097 (quote e) (quote (eval)) g1086) (g446)) (if (memq (quote load) g1117) (if ((lambda (g1119) (if g1119 g1119 (if (eq? g1084 (quote c&e)) (memq (quote eval) g1117) (quote #f)))) (memq (quote compile) g1117)) (g396 g1118 g1082 g1096 g1097 (quote c&e) (quote (compile load)) g1086) (if (memq g1084 (quote (c c&e))) (g396 g1118 g1082 g1096 g1097 (quote c) (quote (load)) g1086) (g446))) (if ((lambda (g1120) (if g1120 g1120 (if (eq? g1084 (quote c&e)) (memq (quote eval) g1117) (quote #f)))) (memq (quote compile) g1117)) (begin (g91 (g396 g1118 g1082 g1096 g1097 (quote e) (quote (eval)) g1086)) (g446)) (g446))))) (g397 g1095 g1114 g1096) (cons g1115 g1116))) g1112) (syntax-error g1111))) ($syntax-dispatch g1111 (quote (any each-any any . each-any))))) g1095) (if (memv g1098 (quote (define-syntax-form))) (g443 g1095 g1096 g1097 (lambda (g1123 g1124 g1125) ((lambda (g1126) (begin ((lambda (g1127) ((lambda (g1128) ((lambda (g1129) (if (memv g1129 (quote (displaced-lexical))) (g250 g1126) (void))) (g232 g1128))) (g253 g1127 g1082))) (g377 g1126 (quote (())))) (g431 g1084 g1085 (lambda () (list (quote $sc-put-cte) (list (quote quote) ((lambda (g1130) (if (g373 (g264 (g206 g1126)) (g264 (quote ((top))))) g1130 ((lambda (g1131) (g203 g1130 (g263 g1131 (list (g304 (vector g1130) (vector g1131) (vector (g101 g1130))))))) (g264 (g206 g1126))))) ((lambda (g1132) ((lambda (g1133) (if (g90 g1133) (annotation-expression g1133) g1133)) (if (g204 g1132) (g205 g1132) g1132))) g1126))) (g432 g1124 (g249 g1082) g1125)))))) (g393 g1123 g1125)))) (if (memv g1098 (quote (define-form))) (g442 g1095 g1096 g1097 (lambda (g1134 g1135 g1136) ((lambda (g1137) (begin ((lambda (g1138) ((lambda (g1139) ((lambda (g1140) (if (memv g1140 (quote (displaced-lexical))) (g250 g1137) (void))) (g232 g1139))) (g253 g1138 g1082))) (g377 g1137 (quote (())))) ((lambda (g1141) ((lambda (g1142) (g190 (quote #f) (list (g431 g1084 g1085 (lambda () (list (quote $sc-put-cte) (list (quote quote) (if (eq? g1141 g1142) g1141 ((lambda (g1143) (g203 g1141 (g263 g1143 (list (g304 (vector g1141) (vector g1143) (vector g1142)))))) (g264 (g206 g1137))))) (list (quote quote) (g231 (quote global) g1142))))) ((lambda (g1144) (begin (if (eq? g1084 (quote c&e)) (g91 g1144) (void)) g1144)) (list (quote define) g1142 (g432 g1135 g1082 g1136)))))) (if (g373 (g264 (g206 g1137)) (g264 (quote ((top))))) g1141 (g101 g1141)))) ((lambda (g1145) ((lambda (g1146) (if (g90 g1146) (annotation-expression g1146) g1146)) (if (g204 g1145) (g205 g1145) g1145))) g1137)))) (g393 g1134 g1136)))) (if (memv g1098 (quote (module-form))) ((lambda (g1147 g1148) (g440 g1095 g1096 g1097 (g263 (g264 g1096) (cons g1148 (g265 g1096))) (lambda (g1149 g1150 g1151) (if g1149 (begin ((lambda (g1152) ((lambda (g1153) ((lambda (g1154) (if (memv g1154 (quote (displaced-lexical))) (g250 (g393 g1149 g1096)) (void))) (g232 g1153))) (g253 g1152 g1147))) (g377 g1149 (quote (())))) (g422 g1095 g1147 g1148 g1096 g1097 g1084 g1085 g1149 g1150 g1151)) (g422 g1095 g1147 g1148 g1096 g1097 g1084 g1085 (quote #f) g1150 g1151))))) (cons (quote ("top-level module placeholder" placeholder)) g1082) (g304 (quote ()) (quote ()) (quote ()))) (if (memv g1098 (quote (import-form))) (g441 g1095 g1096 g1097 (lambda (g1155) (g431 g1084 g1085 (lambda () (begin (if g1094 (syntax-error (g394 g1095 g1096 g1097) (quote "not valid at top-level")) (void)) ((lambda (g1156) ((lambda (g1157) (if (memv g1157 (quote (module))) (g430 g1155 (g405 (g233 g1156))) (if (memv g1157 (quote (displaced-lexical))) (g250 g1155) (syntax-error g1155 (quote "import from unknown module"))))) (g232 g1156))) (g253 (g377 g1155 (quote (()))) (quote ())))))))) ((lambda (g1158) (begin (if (eq? g1084 (quote c&e)) (g91 g1158) (void)) g1158)) (g433 g1093 g1094 g1095 g1082 g1096 g1097)))))))))) g1093))))) (g399 (lambda (g1159 g1160 g1161 g1162) (call-with-values (lambda () (g398 g1159 g1160 g1161 (quote #f) g1162)) (lambda (g1163 g1164 g1165 g1166 g1167) (g433 g1163 g1164 g1165 g1160 g1166 g1167))))) (g398 (lambda (g1168 g1169 g1170 g1171 g1172) (if (symbol? g1168) ((lambda (g1173) ((lambda (g1174) ((lambda (g1175) ((lambda () ((lambda (g1176) (if (memv g1176 (quote (lexical))) (values g1175 (g233 g1174) g1168 g1170 g1171) (if (memv g1176 (quote (global))) (values g1175 (g233 g1174) g1168 g1170 g1171) (if (memv g1176 (quote (macro macro!))) (g398 (g436 (g233 g1174) g1168 g1169 g1170 g1171 g1172) g1169 (quote (())) (quote #f) g1172) (values g1175 (g233 g1174) g1168 g1170 g1171))))) g1175)))) (g232 g1174))) (g253 g1173 g1169))) (g377 g1168 g1170)) (if (pair? g1168) ((lambda (g1177) (if (g256 g1177) ((lambda (g1178) ((lambda (g1179) ((lambda (g1180) ((lambda () ((lambda (g1181) (if (memv g1181 (quote (lexical))) (values (quote lexical-call) (g233 g1179) g1168 g1170 g1171) (if (memv g1181 (quote (macro macro!))) (g398 (g436 (g233 g1179) g1168 g1169 g1170 g1171 g1172) g1169 (quote (())) (quote #f) g1172) (if (memv g1181 (quote (core))) (values g1180 (g233 g1179) g1168 g1170 g1171) (if (memv g1181 (quote (local-syntax))) (values (quote local-syntax-form) (g233 g1179) g1168 g1170 g1171) (if (memv g1181 (quote (begin))) (values (quote begin-form) (quote #f) g1168 g1170 g1171) (if (memv g1181 (quote (eval-when))) (values (quote eval-when-form) (quote #f) g1168 g1170 g1171) (if (memv g1181 (quote (define))) (values (quote define-form) (quote #f) g1168 g1170 g1171) (if (memv g1181 (quote (define-syntax))) (values (quote define-syntax-form) (quote #f) g1168 g1170 g1171) (if (memv g1181 (quote (module-key))) (values (quote module-form) (quote #f) g1168 g1170 g1171) (if (memv g1181 (quote (import))) (values (quote import-form) (if (g233 g1179) (g393 g1177 g1170) (quote #f)) g1168 g1170 g1171) (if (memv g1181 (quote (set!))) (g435 g1168 g1169 g1170 g1171 g1172) (values (quote call) (quote #f) g1168 g1170 g1171))))))))))))) g1180)))) (g232 g1179))) (g253 g1178 g1169))) (g377 g1177 g1170)) (values (quote call) (quote #f) g1168 g1170 g1171))) (car g1168)) (if (g204 g1168) (g398 (g205 g1168) g1169 (g371 g1170 (g206 g1168)) (quote #f) g1172) (if (g90 g1168) (g398 (annotation-expression g1168) g1169 g1170 (annotation-source g1168) g1172) (if ((lambda (g1182) ((lambda (g1183) (if g1183 g1183 ((lambda (g1184) (if g1184 g1184 ((lambda (g1185) (if g1185 g1185 ((lambda (g1186) (if g1186 g1186 (null? g1182))) (char? g1182)))) (string? g1182)))) (number? g1182)))) (boolean? g1182))) g1168) (values (quote constant) (quote #f) g1168 g1170 g1171) (values (quote other) (quote #f) g1168 g1170 g1171)))))))) (g397 (lambda (g1187 g1188 g1189) ((letrec ((g1190 (lambda (g1191 g1192) (if (null? g1191) g1192 (g1190 (cdr g1191) (cons ((lambda (g1193) (if (g378 g1193 (quote #(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*)) () ()))))) (quote compile) (if (g378 g1193 (quote #(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*)) () ()))))) (quote load) (if (g378 g1193 (quote #(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*)) () ()))))) (quote eval) (syntax-error (g393 g1193 g1189) (quote "invalid eval-when situation")))))) (car g1191)) g1192)))))) g1190) g1188 (quote ())))) (g396 (lambda (g1194 g1195 g1196 g1197 g1198 g1199 g1200) (g190 g1197 ((letrec ((g1201 (lambda (g1202 g1203 g1204 g1205 g1206) (if (null? g1202) (quote ()) ((lambda (g1207) (cons g1207 (g1201 (cdr g1202) g1203 g1204 g1205 g1206))) (g400 (car g1202) g1203 g1204 g1205 g1206 g1200)))))) g1201) g1194 g1195 g1196 g1198 g1199)))) (g395 (lambda (g1208 g1209 g1210 g1211) (g190 g1211 ((letrec ((g1212 (lambda (g1213 g1214 g1215) (if (null? g1213) (quote ()) ((lambda (g1216) (cons g1216 (g1212 (cdr g1213) g1214 g1215))) (g432 (car g1213) g1214 g1215)))))) g1212) g1208 g1209 g1210)))) (g394 (lambda (g1217 g1218 g1219) (g393 (if g1219 (make-annotation g1217 g1219 (quote #f)) g1217) g1218))) (g393 (lambda (g1220 g1221) (if (if (null? (g264 g1221)) (null? (g265 g1221)) (quote #f)) g1220 (if (g204 g1220) (g203 (g205 g1220) (g371 g1221 (g206 g1220))) (if (null? g1220) g1220 (g203 g1220 g1221)))))) (g392 (lambda (g1222 g1223) (if (not (null? g1223)) ((lambda (g1224) (if g1224 g1224 (g392 g1222 (cdr g1223)))) (g388 g1222 (car g1223))) (quote #f)))) (g391 (lambda (g1225 g1226 g1227) ((letrec ((g1228 (lambda (g1229 g1230) (if (null? g1229) (syntax-error g1226) (if (g256 (car g1229)) (if (g392 (car g1229) g1230) (syntax-error (car g1229) (quote "duplicate ") g1227) (g1228 (cdr g1229) (cons (car g1229) g1230))) (syntax-error (car g1229) (quote "invalid ") g1227)))))) g1228) g1225 (quote ())))) (g390 (lambda (g1231) ((letrec ((g1232 (lambda (g1233) ((lambda (g1234) (if g1234 g1234 (if (not (g392 (car g1233) (cdr g1233))) (g1232 (cdr g1233)) (quote #f)))) (null? g1233))))) g1232) g1231))) (g389 (lambda (g1235) (if ((letrec ((g1236 (lambda (g1237) ((lambda (g1238) (if g1238 g1238 (if (g256 (car g1237)) (g1236 (cdr g1237)) (quote #f)))) (null? g1237))))) g1236) g1235) (g390 g1235) (quote #f)))) (g388 (lambda (g1239 g1240) (if (if (g204 g1239) (g204 g1240) (quote #f)) (if (eq? ((lambda (g1241) (if (g90 g1241) (annotation-expression g1241) g1241)) (g205 g1239)) ((lambda (g1242) (if (g90 g1242) (annotation-expression g1242) g1242)) (g205 g1240))) (g373 (g264 (g206 g1239)) (g264 (g206 g1240))) (quote #f)) (eq? ((lambda (g1243) (if (g90 g1243) (annotation-expression g1243) g1243)) g1239) ((lambda (g1244) (if (g90 g1244) (annotation-expression g1244) g1244)) g1240))))) (g378 (lambda (g1245 g1246) (if (eq? ((lambda (g1247) ((lambda (g1248) (if (g90 g1248) (annotation-expression g1248) g1248)) (if (g204 g1247) (g205 g1247) g1247))) g1245) ((lambda (g1249) ((lambda (g1250) (if (g90 g1250) (annotation-expression g1250) g1250)) (if (g204 g1249) (g205 g1249) g1249))) g1246)) (eq? (g377 g1245 (quote (()))) (g377 g1246 (quote (())))) (quote #f)))) (g377 (lambda (g1251 g1252) (call-with-values (lambda () (g374 g1251 g1252)) (lambda (g1253 g1254) (if (g301 g1253) (g302 g1253) g1253))))) (g376 (lambda (g1255 g1256) (call-with-values (lambda () (g374 g1255 g1256)) (lambda (g1257 g1258) g1257)))) (g375 (lambda (g1259 g1260) (call-with-values (lambda () (g374 g1259 g1260)) (lambda (g1261 g1262) (values (if (g301 g1261) (g302 g1261) g1261) g1262))))) (g374 (lambda (g1263 g1264) (letrec ((g1267 (lambda (g1268 g1269 g1270 g1271 g1272) ((lambda (g1273) ((letrec ((g1274 (lambda (g1275) (if (= g1275 g1273) (g1265 g1268 (cdr g1269) g1270) (if (if (eq? (vector-ref g1271 g1275) g1268) (g373 g1270 (vector-ref (g307 g1272) g1275)) (quote #f)) (values (vector-ref (g308 g1272) g1275) g1270) (g1274 (+ g1275 (quote 1)))))))) g1274) (quote 0))) (vector-length g1271)))) (g1266 (lambda (g1276 g1277 g1278 g1279 g1280) ((letrec ((g1281 (lambda (g1282 g1283) (if (null? g1282) (g1265 g1276 (cdr g1277) g1278) (if (if (eq? (car g1282) g1276) (g373 g1278 (list-ref (g307 g1280) g1283)) (quote #f)) (values (list-ref (g308 g1280) g1283) g1278) (if (g357 (car g1282)) ((lambda (g1284) (if g1284 ((lambda (g1285) (if (symbol? g1285) (values g1285 g1278) (g375 g1285 (quote (()))))) g1284) (g1281 (cdr g1282) g1283))) (g367 g1276 (g358 (car g1282)) g1278)) (if (if (eq? (car g1282) g354) (g373 g1278 (list-ref (g307 g1280) g1283)) (quote #f)) (values (quote #f) g1278) (g1281 (cdr g1282) (+ g1283 (quote 1)))))))))) g1281) g1279 (quote 0)))) (g1265 (lambda (g1286 g1287 g1288) (if (null? g1287) (values g1286 g1288) ((lambda (g1289) (if (eq? g1289 (quote shift)) (g1265 g1286 (cdr g1287) (cdr g1288)) ((lambda (g1290) (if (vector? g1290) (g1267 g1286 g1287 g1288 g1290 g1289) (g1266 g1286 g1287 g1288 g1290 g1289))) (g306 g1289)))) (car g1287)))))) (if (symbol? g1263) (g1265 g1263 (g265 g1264) (g264 g1264)) (if (g204 g1263) ((lambda (g1291 g1292) ((lambda (g1293) (call-with-values (lambda () (g1265 g1291 (g265 g1264) g1293)) (lambda (g1294 g1295) (if (eq? g1294 g1291) (g1265 g1291 (g265 g1292) g1295) (values g1294 g1295))))) (g372 (g264 g1264) (g264 g1292)))) ((lambda (g1296) (if (g90 g1296) (annotation-expression g1296) g1296)) (g205 g1263)) (g206 g1263)) (if (g90 g1263) (g1265 ((lambda (g1297) (if (g90 g1297) (annotation-expression g1297) g1297)) g1263) (g265 g1264) (g264 g1264)) (g93 (quote id-var-name) (quote "invalid id") g1263))))))) (g373 (lambda (g1298 g1299) ((lambda (g1300) (if g1300 g1300 (if (not (null? g1298)) (if (not (null? g1299)) (if (eq? (car g1298) (car g1299)) (g373 (cdr g1298) (cdr g1299)) (quote #f)) (quote #f)) (quote #f)))) (eq? g1298 g1299)))) (g372 (lambda (g1301 g1302) (g370 g1301 g1302))) (g371 (lambda (g1303 g1304) ((lambda (g1305 g1306) (if (null? g1305) (if (null? g1306) g1304 (g263 (g264 g1304) (g370 g1306 (g265 g1304)))) (g263 (g370 g1305 (g264 g1304)) (g370 g1306 (g265 g1304))))) (g264 g1303) (g265 g1303)))) (g370 (lambda (g1307 g1308) (if (null? g1308) g1307 (append g1307 g1308)))) (g369 (lambda (g1309) (call-with-values (lambda () (g375 g1309 (quote (())))) (lambda (g1310 g1311) (begin (if (not g1310) (syntax-error g1309 (quote "identifier not visible for export")) (void)) ((lambda (g1312) (g203 g1312 (g263 g1311 (list (g304 (vector g1312) (vector g1311) (vector g1310)))))) ((lambda (g1313) ((lambda (g1314) (if (g90 g1314) (annotation-expression g1314) g1314)) (if (g204 g1313) (g205 g1313) g1313))) g1309))))))) (g368 (lambda (g1315 g1316 g1317) (if (null? g1315) g1317 (g263 (g264 g1317) (cons ((lambda (g1318) ((lambda (g1319) ((lambda (g1320 g1321) (begin ((letrec ((g1322 (lambda (g1323 g1324) (if (not (null? g1323)) (call-with-values (lambda () (g262 (car g1323) g1317)) (lambda (g1325 g1326) (begin (vector-set! g1320 g1324 g1325) (vector-set! g1321 g1324 g1326) (g1322 (cdr g1323) (+ g1324 (quote 1)))))) (void))))) g1322) g1315 (quote 0)) (g304 g1320 g1321 g1318))) (make-vector g1319) (make-vector g1319))) (vector-length g1318))) (list->vector g1316)) (g265 g1317)))))) (g367 (lambda (g1327 g1328 g1329) ((lambda (g1330) (if g1330 ((letrec ((g1331 (lambda (g1332) (if (pair? g1332) ((lambda (g1333) (if g1333 g1333 (g1331 (cdr g1332)))) (g1331 (car g1332))) (if (g373 g1329 (g264 (g206 g1332))) g1332 (quote #f)))))) g1331) g1330) (quote #f))) (g100 g1327 g1328)))) (g366 (lambda (g1334 g1335) (g309 g1334 (cons (g356 g1335) (g306 g1334))))) (g365 (lambda (g1336 g1337) (begin (g309 g1336 (cons g354 (g306 g1336))) (g310 g1336 (cons (g264 g1337) (g307 g1336)))))) (g364 (lambda (g1338 g1339) (g365 g1338 (g206 g1339)))) (g363 (lambda (g1340 g1341 g1342) (begin (g309 g1340 (cons ((lambda (g1343) (if (g90 g1343) (annotation-expression g1343) g1343)) (g205 g1341)) (g306 g1340))) (g310 g1340 (cons (g264 (g206 g1341)) (g307 g1340))) (g311 g1340 (cons g1342 (g308 g1340)))))) (g358 cdr) (g357 (lambda (g1344) (if (pair? g1344) (eq? (car g1344) g355) (quote #f)))) (g356 (lambda (g1345) (cons g355 g1345))) (g355 (quote import-token)) (g354 (quote #f)) (g349 (lambda (g1346) (g263 (cons (quote #f) (g264 g1346)) (cons (quote shift) (g265 g1346))))) (g311 (lambda (g1347 g1348) (vector-set! g1347 (quote 3) g1348))) (g310 (lambda (g1349 g1350) (vector-set! g1349 (quote 2) g1350))) (g309 (lambda (g1351 g1352) (vector-set! g1351 (quote 1) g1352))) (g308 (lambda (g1353) (vector-ref g1353 (quote 3)))) (g307 (lambda (g1354) (vector-ref g1354 (quote 2)))) (g306 (lambda (g1355) (vector-ref g1355 (quote 1)))) (g305 (lambda (g1356) (if (vector? g1356) (if (= (vector-length g1356) (quote 4)) (eq? (vector-ref g1356 (quote 0)) (quote ribcage)) (quote #f)) (quote #f)))) (g304 (lambda (g1357 g1358 g1359) (vector (quote ribcage) g1357 g1358 g1359))) (g303 set-car!) (g302 car) (g301 pair?) (g300 (lambda () (list (g297)))) (g299 (lambda (g1360) (if (null? g1360) (quote ()) (cons (g297) (g299 (cdr g1360)))))) (g298 (lambda (g1361) ((lambda (g1362) (if g1362 g1362 ((lambda (g1363) (if g1363 g1363 (g301 g1361))) (symbol? g1361)))) (string? g1361)))) (g297 (lambda () (string (quote #\i)))) (g265 cdr) (g264 car) (g263 cons) (g262 (lambda (g1364 g1365) (if (g204 g1364) (values ((lambda (g1366) (if (g90 g1366) (annotation-expression g1366) g1366)) (g205 g1364)) (g372 (g264 g1365) (g264 (g206 g1364)))) (values ((lambda (g1367) (if (g90 g1367) (annotation-expression g1367) g1367)) g1364) (g264 g1365))))) (g256 (lambda (g1368) (if (symbol? g1368) (quote #t) (if (g204 g1368) (symbol? ((lambda (g1369) (if (g90 g1369) (annotation-expression g1369) g1369)) (g205 g1368))) (if (g90 g1368) (symbol? (annotation-expression g1368)) (quote #f)))))) (g255 (lambda (g1370) (if (g204 g1370) (symbol? ((lambda (g1371) (if (g90 g1371) (annotation-expression g1371) g1371)) (g205 g1370))) (quote #f)))) (g254 (lambda (g1372 g1373 g1374) (g98 g1373 (g231 g1372 g1374)))) (g253 (lambda (g1375 g1376) (letrec ((g1377 (lambda (g1378 g1379) (begin (g234 g1378 (g232 g1379)) (g235 g1378 (g233 g1379)))))) ((lambda (g1380) ((lambda (g1381) (if (memv g1381 (quote (deferred))) (begin (g1377 g1380 ((lambda (g1382) ((lambda (g1383) (if g1383 g1383 (syntax-error g1382 (quote "invalid transformer")))) (g252 g1382))) (g92 (g233 g1380)))) ((lambda (g1384) g1380) (g232 g1380))) g1380)) (g232 g1380))) (g251 g1375 g1376))))) (g252 (lambda (g1385) (if (procedure? g1385) (g231 (quote macro) g1385) (if (g236 g1385) ((lambda (g1386) (if (memv g1386 (quote (core macro macro!))) (if (procedure? (g233 g1385)) g1385 (quote #f)) (if (memv g1386 (quote (module))) (if (g403 (g233 g1385)) g1385 (quote #f)) g1385))) (g232 g1385)) (quote #f))))) (g251 (lambda (g1387 g1388) ((lambda (g1389) (if g1389 (cdr g1389) (if (symbol? g1387) ((lambda (g1390) (if g1390 g1390 (g231 (quote global) g1387))) (g99 g1387)) (g231 (quote displaced-lexical) (quote #f))))) (assq g1387 g1388)))) (g250 (lambda (g1391) (syntax-error g1391 (if (g377 g1391 (quote (()))) (quote "identifier out of context") (quote "identifier not visible"))))) (g249 (lambda (g1392) (if (null? g1392) (quote ()) ((lambda (g1393) (if (eq? (cadr g1393) (quote lexical)) (g249 (cdr g1392)) (cons g1393 (g249 (cdr g1392))))) (car g1392))))) (g248 (lambda (g1394 g1395 g1396) (if (null? g1394) g1396 (g248 (cdr g1394) (cdr g1395) (g246 (car g1394) (g231 (quote lexical) (car g1395)) g1396))))) (g247 (lambda (g1397 g1398 g1399) (if (null? g1397) g1399 (g247 (cdr g1397) (cdr g1398) (g246 (car g1397) (car g1398) g1399))))) (g246 (lambda (g1400 g1401 g1402) (cons (cons g1400 g1401) g1402))) (g236 (lambda (g1403) (if (pair? g1403) (symbol? (car g1403)) (quote #f)))) (g235 set-cdr!) (g234 set-car!) (g233 cdr) (g232 car) (g231 (lambda (g1404 g1405) (cons g1404 g1405))) (g223 (lambda (g1406) (if (g90 g1406) (annotation-source g1406) (if (g204 g1406) (g223 (g205 g1406)) (quote #f))))) (g208 (lambda (g1407 g1408) (vector-set! g1407 (quote 2) g1408))) (g207 (lambda (g1409 g1410) (vector-set! g1409 (quote 1) g1410))) (g206 (lambda (g1411) (vector-ref g1411 (quote 2)))) (g205 (lambda (g1412) (vector-ref g1412 (quote 1)))) (g204 (lambda (g1413) (if (vector? g1413) (if (= (vector-length g1413) (quote 3)) (eq? (vector-ref g1413 (quote 0)) (quote syntax-object)) (quote #f)) (quote #f)))) (g203 (lambda (g1414 g1415) (vector (quote syntax-object) g1414 g1415))) (g191 (lambda (g1416 g1417 g1418 g1419) (if (null? g1417) g1419 (list (quote letrec) (map list g1417 g1418) g1419)))) (g190 (lambda (g1420 g1421) (if (null? (cdr g1421)) (car g1421) (cons (quote begin) g1421)))) (g101 ((lambda (g1422) (letrec ((g1425 (lambda (g1426) ((letrec ((g1427 (lambda (g1428 g1429) (if (< g1428 g1422) (list->string (cons (g1424 g1428) g1429)) ((lambda (g1430 g1431) (g1427 g1431 (cons (g1424 g1430) g1429))) (modulo g1428 g1422) (quotient g1428 g1422)))))) g1427) g1426 (quote ())))) (g1424 (lambda (g1432) (integer->char (+ g1432 (quote 33))))) (g1423 (lambda () (quote 0)))) ((lambda (g1433 g1434) (lambda (g1435) (begin (set! g1434 (+ g1434 (quote 1))) ((lambda (g1436) g1436) (string->symbol (string-append (quote "#") g1433 (g1425 g1434))))))) (g1425 (g1423)) (quote -1)))) (- (quote 127) (quote 32) (quote 2)))) (g100 (lambda (g1437 g1438) (getprop g1437 g1438))) (g99 (lambda (g1439) (getprop g1439 (quote *sc-expander*)))) (g98 (lambda (g1440 g1441) ($sc-put-cte g1440 g1441))) (g93 (lambda (g1442 g1443 g1444) (error g1443 g1444))) (g92 sc-eval) (g91 sc-eval) (g90 (lambda (g1445) (quote #f))) (g53 (quote "noexpand"))) (begin (set! $sc-put-cte (lambda (g1446 g1447) (letrec ((g1450 (lambda (g1451 g1452) ((lambda (g1453) (putprop g1453 (quote *sc-expander*) g1452)) (if (symbol? g1451) g1451 (g377 g1451 (quote (()))))))) (g1449 (lambda (g1454 g1455) (g429 (lambda (g1456) (g1448 g1456 g1455)) g1454))) (g1448 (lambda (g1457 g1458) (letrec ((g1460 (lambda (g1461 g1462) (if (pair? g1462) (if (g388 (car g1462) g1461) (g1460 g1461 (cdr g1462)) (g1459 (car g1462) (g1460 g1461 (cdr g1462)))) (if ((lambda (g1463) (if g1463 g1463 (g388 g1462 g1461))) (not g1462)) (quote #f) g1462)))) (g1459 (lambda (g1464 g1465) (if (not g1465) g1464 (cons g1464 g1465))))) ((lambda (g1466) ((lambda (g1467) (if (if (not g1467) (symbol? g1457) (quote #f)) (remprop g1466 g1458) (putprop g1466 g1458 (g1459 g1457 g1467)))) (g1460 g1457 (getprop g1466 g1458)))) ((lambda (g1468) ((lambda (g1469) (if (g90 g1469) (annotation-expression g1469) g1469)) (if (g204 g1468) (g205 g1468) g1468))) g1457)))))) ((lambda (g1470) ((lambda (g1471) (if (memv g1471 (quote (module))) (begin ((lambda (g1472) (g1449 (g404 g1472) (g405 g1472))) (g233 g1470)) (g1450 g1446 g1470)) (if (memv g1471 (quote (do-import))) ((lambda (g1473) ((lambda (g1474) ((lambda (g1475) (if (memv g1475 (quote (module))) ((lambda (g1476) (begin (if (not (eq? (g405 g1476) g1473)) (syntax-error g1446 (quote "import mismatch for module")) (void)) (g1449 (g404 g1476) (quote *top*)))) (g233 g1474)) (syntax-error g1446 (quote "import from unknown module")))) (g232 g1474))) (g253 (g377 g1446 (quote (()))) (quote ())))) (g233 g1447)) (g1450 g1446 g1470)))) (g232 g1470))) ((lambda (g1477) (if g1477 g1477 (error (quote define-syntax) (quote "invalid transformer ~s") g1447))) (g252 g1447)))))) (g254 (quote local-syntax) (quote letrec-syntax) (quote #t)) (g254 (quote local-syntax) (quote let-syntax) (quote #f)) (g254 (quote core) (quote fluid-let-syntax) (lambda (g1478 g1479 g1480 g1481) ((lambda (g1482) ((lambda (g1483) (if (if g1483 (apply (lambda (g1484 g1485 g1486 g1487 g1488) (g389 g1485)) g1483) (quote #f)) (apply (lambda (g1490 g1491 g1492 g1493 g1494) ((lambda (g1495) (begin (for-each (lambda (g1496 g1497) ((lambda (g1498) (if (memv g1498 (quote (displaced-lexical))) (g250 (g393 g1496 g1480)) (void))) (g232 (g253 g1497 g1479)))) g1491 g1495) (g437 (cons g1493 g1494) (g394 g1478 g1480 g1481) (g247 g1495 ((lambda (g1501) (map (lambda (g1502) (g231 (quote deferred) (g432 g1502 g1501 g1480))) g1492)) (g249 g1479)) g1479) g1480))) (map (lambda (g1504) (g377 g1504 g1480)) g1491))) g1483) ((lambda (g1506) (syntax-error (g394 g1478 g1480 g1481))) g1482))) ($syntax-dispatch g1482 (quote (any #(each (any any)) any . each-any))))) g1478))) (g254 (quote core) (quote quote) (lambda (g1507 g1508 g1509 g1510) ((lambda (g1511) ((lambda (g1512) (if g1512 (apply (lambda (g1513 g1514) (list (quote quote) (g450 g1514 g1509))) g1512) ((lambda (g1515) (syntax-error (g394 g1507 g1509 g1510))) g1511))) ($syntax-dispatch g1511 (quote (any any))))) g1507))) (g254 (quote core) (quote syntax) ((lambda () (letrec ((g1523 (lambda (g1524) ((lambda (g1525) (if (memv g1525 (quote (ref))) (cadr g1524) (if (memv g1525 (quote (primitive))) (cadr g1524) (if (memv g1525 (quote (quote))) (list (quote quote) (cadr g1524)) (if (memv g1525 (quote (lambda))) (list (quote lambda) (cadr g1524) (g1523 (caddr g1524))) (if (memv g1525 (quote (map))) ((lambda (g1526) (cons (if (= (length g1526) (quote 2)) (quote map) (quote map)) g1526)) (map g1523 (cdr g1524))) (cons (car g1524) (map g1523 (cdr g1524))))))))) (car g1524)))) (g1522 (lambda (g1527) (if (eq? (car g1527) (quote list)) (cons (quote vector) (cdr g1527)) (if (eq? (car g1527) (quote quote)) (list (quote quote) (list->vector (cadr g1527))) (list (quote list->vector) g1527))))) (g1521 (lambda (g1528 g1529) (if (equal? g1529 (quote (quote ()))) g1528 (list (quote append) g1528 g1529)))) (g1520 (lambda (g1530 g1531) ((lambda (g1532) (if (memv g1532 (quote (quote))) (if (eq? (car g1530) (quote quote)) (list (quote quote) (cons (cadr g1530) (cadr g1531))) (if (eq? (cadr g1531) (quote ())) (list (quote list) g1530) (list (quote cons) g1530 g1531))) (if (memv g1532 (quote (list))) (cons (quote list) (cons g1530 (cdr g1531))) (list (quote cons) g1530 g1531)))) (car g1531)))) (g1519 (lambda (g1533 g1534) ((lambda (g1535 g1536) (if (eq? (car g1533) (quote ref)) (car g1536) (if (andmap (lambda (g1537) (if (eq? (car g1537) (quote ref)) (memq (cadr g1537) g1535) (quote #f))) (cdr g1533)) (cons (quote map) (cons (list (quote primitive) (car g1533)) (map ((lambda (g1538) (lambda (g1539) (cdr (assq (cadr g1539) g1538)))) (map cons g1535 g1536)) (cdr g1533)))) (cons (quote map) (cons (list (quote lambda) g1535 g1533) g1536))))) (map cdr g1534) (map (lambda (g1540) (list (quote ref) (car g1540))) g1534)))) (g1518 (lambda (g1541 g1542) (list (quote apply) (quote (primitive append)) (g1519 g1541 g1542)))) (g1517 (lambda (g1543 g1544 g1545 g1546) (if (= g1545 (quote 0)) (values g1544 g1546) (if (null? g1546) (syntax-error g1543 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (g1517 g1543 g1544 (- g1545 (quote 1)) (cdr g1546))) (lambda (g1547 g1548) ((lambda (g1549) (if g1549 (values (cdr g1549) g1546) ((lambda (g1550) (values g1550 (cons (cons (cons g1547 g1550) (car g1546)) g1548))) (g451 (quote tmp))))) (assq g1547 (car g1546))))))))) (g1516 (lambda (g1551 g1552 g1553 g1554 g1555) (if (g256 g1552) ((lambda (g1556) ((lambda (g1557) (if (eq? (g232 g1557) (quote syntax)) (call-with-values (lambda () ((lambda (g1558) (g1517 g1551 (car g1558) (cdr g1558) g1554)) (g233 g1557))) (lambda (g1559 g1560) (values (list (quote ref) g1559) g1560))) (if (g1555 g1552) (syntax-error g1551 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) g1552) g1554)))) (g253 g1556 g1553))) (g377 g1552 (quote (())))) ((lambda (g1561) ((lambda (g1562) (if (if g1562 (apply (lambda (g1563 g1564) (g1555 g1563)) g1562) (quote #f)) (apply (lambda (g1565 g1566) (g1516 g1551 g1566 g1553 g1554 (lambda (g1567) (quote #f)))) g1562) ((lambda (g1568) (if (if g1568 (apply (lambda (g1569 g1570 g1571) (g1555 g1570)) g1568) (quote #f)) (apply (lambda (g1572 g1573 g1574) ((letrec ((g1575 (lambda (g1576 g1577) ((lambda (g1578) ((lambda (g1579) (if (if g1579 (apply (lambda (g1580 g1581) (g1555 g1580)) g1579) (quote #f)) (apply (lambda (g1582 g1583) (g1575 g1583 (lambda (g1584) (call-with-values (lambda () (g1577 (cons (quote ()) g1584))) (lambda (g1585 g1586) (if (null? (car g1586)) (syntax-error g1551 (quote "extra ellipsis in syntax form")) (values (g1518 g1585 (car g1586)) (cdr g1586)))))))) g1579) ((lambda (g1587) (call-with-values (lambda () (g1516 g1551 g1576 g1553 g1554 g1555)) (lambda (g1588 g1589) (call-with-values (lambda () (g1577 g1589)) (lambda (g1590 g1591) (values (g1521 g1590 g1588) g1591)))))) g1578))) ($syntax-dispatch g1578 (quote (any . any))))) g1576)))) g1575) g1574 (lambda (g1592) (call-with-values (lambda () (g1516 g1551 g1572 g1553 (cons (quote ()) g1592) g1555)) (lambda (g1593 g1594) (if (null? (car g1594)) (syntax-error g1551 (quote "extra ellipsis in syntax form")) (values (g1519 g1593 (car g1594)) (cdr g1594)))))))) g1568) ((lambda (g1595) (if g1595 (apply (lambda (g1596 g1597) (call-with-values (lambda () (g1516 g1551 g1596 g1553 g1554 g1555)) (lambda (g1598 g1599) (call-with-values (lambda () (g1516 g1551 g1597 g1553 g1599 g1555)) (lambda (g1600 g1601) (values (g1520 g1598 g1600) g1601)))))) g1595) ((lambda (g1602) (if g1602 (apply (lambda (g1603 g1604) (call-with-values (lambda () (g1516 g1551 (cons g1603 g1604) g1553 g1554 g1555)) (lambda (g1606 g1607) (values (g1522 g1606) g1607)))) g1602) ((lambda (g1608) (values (list (quote quote) g1552) g1554)) g1561))) ($syntax-dispatch g1561 (quote #(vector (any . each-any))))))) ($syntax-dispatch g1561 (quote (any . any)))))) ($syntax-dispatch g1561 (quote (any any . any)))))) ($syntax-dispatch g1561 (quote (any any))))) g1552))))) (lambda (g1609 g1610 g1611 g1612) ((lambda (g1613) ((lambda (g1614) ((lambda (g1615) (if g1615 (apply (lambda (g1616 g1617) (call-with-values (lambda () (g1516 g1613 g1617 g1610 (quote ()) g447)) (lambda (g1618 g1619) (g1523 g1618)))) g1615) ((lambda (g1620) (syntax-error g1613)) g1614))) ($syntax-dispatch g1614 (quote (any any))))) g1613)) (g394 g1609 g1611 g1612))))))) (g254 (quote core) (quote lambda) (lambda (g1621 g1622 g1623 g1624) ((lambda (g1625) ((lambda (g1626) (if g1626 (apply (lambda (g1627 g1628) (g444 (g394 g1621 g1623 g1624) g1628 g1622 g1623 (lambda (g1629 g1630) (list (quote lambda) g1629 g1630)))) g1626) (syntax-error g1625))) ($syntax-dispatch g1625 (quote (any . any))))) g1621))) (g254 (quote core) (quote letrec) (lambda (g1631 g1632 g1633 g1634) ((lambda (g1635) ((lambda (g1636) (if g1636 (apply (lambda (g1637 g1638 g1639 g1640 g1641) ((lambda (g1642) (if (not (g389 g1642)) (g391 (map (lambda (g1643) (g393 g1643 g1633)) g1642) (g394 g1631 g1633 g1634) (quote "bound variable")) ((lambda (g1644 g1645) ((lambda (g1646 g1647) (g191 g1634 g1645 (map (lambda (g1648) (g432 g1648 g1647 g1646)) g1639) (g437 (cons g1640 g1641) (g394 g1631 g1646 g1634) g1647 g1646))) (g368 g1642 g1644 g1633) (g248 g1644 g1645 g1632))) (g299 g1642) (map g451 g1642)))) g1638)) g1636) ((lambda (g1652) (syntax-error (g394 g1631 g1633 g1634))) g1635))) ($syntax-dispatch g1635 (quote (any #(each (any any)) any . each-any))))) g1631))) (g254 (quote core) (quote if) (lambda (g1653 g1654 g1655 g1656) ((lambda (g1657) ((lambda (g1658) (if g1658 (apply (lambda (g1659 g1660 g1661) (list (quote if) (g432 g1660 g1654 g1655) (g432 g1661 g1654 g1655) (g446))) g1658) ((lambda (g1662) (if g1662 (apply (lambda (g1663 g1664 g1665 g1666) (list (quote if) (g432 g1664 g1654 g1655) (g432 g1665 g1654 g1655) (g432 g1666 g1654 g1655))) g1662) ((lambda (g1667) (syntax-error (g394 g1653 g1655 g1656))) g1657))) ($syntax-dispatch g1657 (quote (any any any any)))))) ($syntax-dispatch g1657 (quote (any any any))))) g1653))) (g254 (quote set!) (quote set!) (quote ())) (g254 (quote begin) (quote begin) (quote ())) (g254 (quote module-key) (quote module) (quote ())) (g254 (quote import) (quote import) (quote #f)) (g254 (quote import) (quote import-only) (quote #t)) (g254 (quote define) (quote define) (quote ())) (g254 (quote define-syntax) (quote define-syntax) (quote ())) (g254 (quote eval-when) (quote eval-when) (quote ())) (g254 (quote core) (quote syntax-case) ((lambda () (letrec ((g1671 (lambda (g1672 g1673 g1674 g1675) (if (null? g1674) (list (quote syntax-error) g1672) ((lambda (g1676) ((lambda (g1677) (if g1677 (apply (lambda (g1678 g1679) (if (if (g256 g1678) (if (not (g392 g1678 g1673)) (not (g447 g1678)) (quote #f)) (quote #f)) ((lambda (g1680 g1681) (list (list (quote lambda) (list g1681) (g432 g1679 (g246 g1680 (g231 (quote syntax) (cons g1681 (quote 0))) g1675) (g368 (list g1678) (list g1680) (quote (()))))) g1672)) (g297) (g451 g1678)) (g1670 g1672 g1673 (cdr g1674) g1675 g1678 (quote #t) g1679))) g1677) ((lambda (g1682) (if g1682 (apply (lambda (g1683 g1684 g1685) (g1670 g1672 g1673 (cdr g1674) g1675 g1683 g1684 g1685)) g1682) ((lambda (g1686) (syntax-error (car g1674) (quote "invalid syntax-case clause"))) g1676))) ($syntax-dispatch g1676 (quote (any any any)))))) ($syntax-dispatch g1676 (quote (any any))))) (car g1674))))) (g1670 (lambda (g1687 g1688 g1689 g1690 g1691 g1692 g1693) (call-with-values (lambda () (g1668 g1691 g1688)) (lambda (g1694 g1695) (if (not (g390 (map car g1695))) (g391 (map car g1695) g1691 (quote "pattern variable")) (if (not (andmap (lambda (g1696) (not (g447 (car g1696)))) g1695)) (syntax-error g1691 (quote "misplaced ellipsis in syntax-case pattern")) ((lambda (g1697) (list (list (quote lambda) (list g1697) (list (quote if) ((lambda (g1707) ((lambda (g1708) (if g1708 (apply (lambda () g1697) g1708) ((lambda (g1709) (list (quote if) g1697 (g1669 g1695 g1692 g1697 g1690) (list (quote quote) (quote #f)))) g1707))) ($syntax-dispatch g1707 (quote #(atom #t))))) g1692) (g1669 g1695 g1693 g1697 g1690) (g1671 g1687 g1688 g1689 g1690))) (if (eq? g1694 (quote any)) (list (quote list) g1687) (list (quote $syntax-dispatch) g1687 (list (quote quote) g1694))))) (g451 (quote tmp))))))))) (g1669 (lambda (g1710 g1711 g1712 g1713) ((lambda (g1714 g1715) ((lambda (g1716 g1717) (list (quote apply) (list (quote lambda) g1717 (g432 g1711 (g247 g1716 (map (lambda (g1718 g1719) (g231 (quote syntax) (cons g1718 g1719))) g1717 (map cdr g1710)) g1713) (g368 g1714 g1716 (quote (()))))) g1712)) (g299 g1714) (map g451 g1714))) (map car g1710) (map cdr g1710)))) (g1668 (lambda (g1720 g1721) ((letrec ((g1722 (lambda (g1723 g1724 g1725) (if (g256 g1723) (if (g392 g1723 g1721) (values (vector (quote free-id) g1723) g1725) (values (quote any) (cons (cons g1723 g1724) g1725))) ((lambda (g1726) ((lambda (g1727) (if (if g1727 (apply (lambda (g1728 g1729) (g447 g1729)) g1727) (quote #f)) (apply (lambda (g1730 g1731) (call-with-values (lambda () (g1722 g1730 (+ g1724 (quote 1)) g1725)) (lambda (g1732 g1733) (values (if (eq? g1732 (quote any)) (quote each-any) (vector (quote each) g1732)) g1733)))) g1727) ((lambda (g1734) (if g1734 (apply (lambda (g1735 g1736) (call-with-values (lambda () (g1722 g1736 g1724 g1725)) (lambda (g1737 g1738) (call-with-values (lambda () (g1722 g1735 g1724 g1738)) (lambda (g1739 g1740) (values (cons g1739 g1737) g1740)))))) g1734) ((lambda (g1741) (if g1741 (apply (lambda () (values (quote ()) g1725)) g1741) ((lambda (g1742) (if g1742 (apply (lambda (g1743) (call-with-values (lambda () (g1722 g1743 g1724 g1725)) (lambda (g1745 g1746) (values (vector (quote vector) g1745) g1746)))) g1742) ((lambda (g1747) (values (vector (quote atom) (g450 g1723 (quote (())))) g1725)) g1726))) ($syntax-dispatch g1726 (quote #(vector each-any)))))) ($syntax-dispatch g1726 (quote ()))))) ($syntax-dispatch g1726 (quote (any . any)))))) ($syntax-dispatch g1726 (quote (any any))))) g1723))))) g1722) g1720 (quote 0) (quote ()))))) (lambda (g1748 g1749 g1750 g1751) ((lambda (g1752) ((lambda (g1753) ((lambda (g1754) (if g1754 (apply (lambda (g1755 g1756 g1757 g1758) (if (andmap (lambda (g1759) (if (g256 g1759) (not (g447 g1759)) (quote #f))) g1757) ((lambda (g1761) (list (list (quote lambda) (list g1761) (g1671 g1761 g1757 g1758 g1749)) (g432 g1756 g1749 (quote (()))))) (g451 (quote tmp))) (syntax-error g1752 (quote "invalid literals list in")))) g1754) (syntax-error g1753))) ($syntax-dispatch g1753 (quote (any any each-any . each-any))))) g1752)) (g394 g1748 g1750 g1751))))))) (set! sc-expand ((lambda (g1764) ((lambda (g1765) (lambda (g1766) ((lambda (g1767 g1768) (if (if (pair? g1766) (equal? (car g1766) g53) (quote #f)) (cadr g1766) (g400 g1766 (quote ()) g1765 g1767 g1768 g1764))) (quote e) (quote (eval))))) (g263 (g264 (quote ((top)))) (cons g1764 (g265 (quote ((top)))))))) ((lambda (g1769) (begin (g366 g1769 (quote *top*)) g1769)) (g304 (quote ()) (quote ()) (quote ()))))) (set! identifier? (lambda (g1770) (g255 g1770))) (set! datum->syntax-object (lambda (g1771 g1772) (begin ((lambda (g1773) (if (not (g255 g1773)) (g93 (quote datum->syntax-object) (quote "invalid argument") g1773) (void))) g1771) (g203 g1772 (g206 g1771))))) (set! syntax-object->datum (lambda (g1774) (g450 g1774 (quote (()))))) (set! generate-temporaries (lambda (g1775) (begin ((lambda (g1776) (if (not (list? g1776)) (g93 (quote generate-temporaries) (quote "invalid argument") g1776) (void))) g1775) (map (lambda (g1777) (g393 (gensym) (quote ((top))))) g1775)))) (set! free-identifier=? (lambda (g1778 g1779) (begin ((lambda (g1780) (if (not (g255 g1780)) (g93 (quote free-identifier=?) (quote "invalid argument") g1780) (void))) g1778) ((lambda (g1781) (if (not (g255 g1781)) (g93 (quote free-identifier=?) (quote "invalid argument") g1781) (void))) g1779) (g378 g1778 g1779)))) (set! bound-identifier=? (lambda (g1782 g1783) (begin ((lambda (g1784) (if (not (g255 g1784)) (g93 (quote bound-identifier=?) (quote "invalid argument") g1784) (void))) g1782) ((lambda (g1785) (if (not (g255 g1785)) (g93 (quote bound-identifier=?) (quote "invalid argument") g1785) (void))) g1783) (g388 g1782 g1783)))) (set! syntax-error (lambda (g1787 . g1786) (begin (for-each (lambda (g1788) ((lambda (g1789) (if (not (string? g1789)) (g93 (quote syntax-error) (quote "invalid argument") g1789) (void))) g1788)) g1786) ((lambda (g1790) (g93 (quote #f) g1790 (g450 g1787 (quote (()))))) (if (null? g1786) (quote "invalid syntax") (apply string-append g1786)))))) ((lambda () (letrec ((g1795 (lambda (g1796 g1797 g1798 g1799) (if (not g1799) (quote #f) (if (eq? g1797 (quote any)) (cons (g393 g1796 g1798) g1799) (if (g204 g1796) (g1794 ((lambda (g1800) (if (g90 g1800) (annotation-expression g1800) g1800)) (g205 g1796)) g1797 (g371 g1798 (g206 g1796)) g1799) (g1794 ((lambda (g1801) (if (g90 g1801) (annotation-expression g1801) g1801)) g1796) g1797 g1798 g1799)))))) (g1794 (lambda (g1802 g1803 g1804 g1805) (if (null? g1803) (if (null? g1802) g1805 (quote #f)) (if (pair? g1803) (if (pair? g1802) (g1795 (car g1802) (car g1803) g1804 (g1795 (cdr g1802) (cdr g1803) g1804 g1805)) (quote #f)) (if (eq? g1803 (quote each-any)) ((lambda (g1806) (if g1806 (cons g1806 g1805) (quote #f))) (g1792 g1802 g1804)) ((lambda (g1807) (if (memv g1807 (quote (each))) (if (null? g1802) (g1793 (vector-ref g1803 (quote 1)) g1805) ((lambda (g1808) (if g1808 ((letrec ((g1809 (lambda (g1810) (if (null? (car g1810)) g1805 (cons (map car g1810) (g1809 (map cdr g1810))))))) g1809) g1808) (quote #f))) (g1791 g1802 (vector-ref g1803 (quote 1)) g1804))) (if (memv g1807 (quote (free-id))) (if (g256 g1802) (if (g378 (g393 g1802 g1804) (vector-ref g1803 (quote 1))) g1805 (quote #f)) (quote #f)) (if (memv g1807 (quote (atom))) (if (equal? (vector-ref g1803 (quote 1)) (g450 g1802 g1804)) g1805 (quote #f)) (if (memv g1807 (quote (vector))) (if (vector? g1802) (g1795 (vector->list g1802) (vector-ref g1803 (quote 1)) g1804 g1805) (quote #f)) (void)))))) (vector-ref g1803 (quote 0)))))))) (g1793 (lambda (g1811 g1812) (if (null? g1811) g1812 (if (eq? g1811 (quote any)) (cons (quote ()) g1812) (if (pair? g1811) (g1793 (car g1811) (g1793 (cdr g1811) g1812)) (if (eq? g1811 (quote each-any)) (cons (quote ()) g1812) ((lambda (g1813) (if (memv g1813 (quote (each))) (g1793 (vector-ref g1811 (quote 1)) g1812) (if (memv g1813 (quote (free-id atom))) g1812 (if (memv g1813 (quote (vector))) (g1793 (vector-ref g1811 (quote 1)) g1812) (void))))) (vector-ref g1811 (quote 0))))))))) (g1792 (lambda (g1814 g1815) (if (g90 g1814) (g1792 (annotation-expression g1814) g1815) (if (pair? g1814) ((lambda (g1816) (if g1816 (cons (g393 (car g1814) g1815) g1816) (quote #f))) (g1792 (cdr g1814) g1815)) (if (null? g1814) (quote ()) (if (g204 g1814) (g1792 (g205 g1814) (g371 g1815 (g206 g1814))) (quote #f))))))) (g1791 (lambda (g1817 g1818 g1819) (if (g90 g1817) (g1791 (annotation-expression g1817) g1818 g1819) (if (pair? g1817) ((lambda (g1820) (if g1820 ((lambda (g1821) (if g1821 (cons g1820 g1821) (quote #f))) (g1791 (cdr g1817) g1818 g1819)) (quote #f))) (g1795 (car g1817) g1818 g1819 (quote ()))) (if (null? g1817) (quote ()) (if (g204 g1817) (g1791 (g205 g1817) g1818 (g371 g1819 (g206 g1817))) (quote #f)))))))) (set! $syntax-dispatch (lambda (g1822 g1823) (if (eq? g1823 (quote any)) (list g1822) (if (g204 g1822) (g1794 ((lambda (g1824) (if (g90 g1824) (annotation-expression g1824) g1824)) (g205 g1822)) g1823 (g206 g1822) (quote ())) (g1794 ((lambda (g1825) (if (g90 g1825) (annotation-expression g1825) g1825)) g1822) g1823 (quote (())) (quote ())))))))))))))($sc-put-cte (quote with-syntax) (lambda (g1826) ((lambda (g1827) ((lambda (g1828) (if g1828 (apply (lambda (g1829 g1830 g1831) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ())))) (cons g1830 g1831))) g1828) ((lambda (g1833) (if g1833 (apply (lambda (g1834 g1835 g1836 g1837 g1838) (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")) #(ribcage ((import-token . *top*)) () ())))) g1836 (quote ()) (list g1835 (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")) #(ribcage ((import-token . *top*)) () ())))) (cons g1837 g1838))))) g1833) ((lambda (g1840) (if g1840 (apply (lambda (g1841 g1842 g1843 g1844 g1845) (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")) #(ribcage ((import-token . *top*)) () ())))) (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")) #(ribcage ((import-token . *top*)) () ())))) g1843) (quote ()) (list g1842 (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")) #(ribcage ((import-token . *top*)) () ())))) (cons g1844 g1845))))) g1840) (syntax-error g1827))) ($syntax-dispatch g1827 (quote (any #(each (any any)) any . each-any)))))) ($syntax-dispatch g1827 (quote (any ((any any)) any . each-any)))))) ($syntax-dispatch g1827 (quote (any () any . each-any))))) g1826)))($sc-put-cte (quote syntax-rules) (lambda (g1849) ((lambda (g1850) ((lambda (g1851) (if g1851 (apply (lambda (g1852 g1853 g1854 g1855 g1856) (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")) #(ribcage ((import-token . *top*)) () ())))) (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")) #(ribcage ((import-token . *top*)) () ()))))) (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")) #(ribcage ((import-token . *top*)) () ())))) (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")) #(ribcage ((import-token . *top*)) () ())))) (cons g1853 (map (lambda (g1859 g1858) (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")) #(ribcage ((import-token . *top*)) () ())))) g1858) (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")) #(ribcage ((import-token . *top*)) () ())))) g1859))) g1856 g1855)))))) g1851) (syntax-error g1850))) ($syntax-dispatch g1850 (quote (any each-any . #(each ((any . any) any))))))) g1849)))($sc-put-cte (quote cond) (lambda (g1860) ((lambda (g1861) ((lambda (g1862) (if g1862 (apply (lambda (g1863 g1864 g1865) ((letrec ((g1866 (lambda (g1867 g1868) (if (null? g1868) ((lambda (g1869) ((lambda (g1870) (if g1870 (apply (lambda (g1871 g1872) (cons (quote #(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 g1871 g1872))) g1870) ((lambda (g1874) (if g1874 (apply (lambda (g1875) (cons (quote #(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 (quote #(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*)) () ())))) g1875)) (quote ((#(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*)) () ()))))))))) g1874) ((lambda (g1876) (if g1876 (apply (lambda (g1877 g1878) (list (quote #(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 (quote #(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*)) () ())))) g1877)) (list (quote #(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*)) () ())))) (quote #(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 g1878 (quote (#(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*)) () ()))))))))) g1876) ((lambda (g1879) (if g1879 (apply (lambda (g1880 g1881 g1882) (list (quote #(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*)) () ())))) g1880 (cons (quote #(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 g1881 g1882)))) g1879) ((lambda (g1884) (syntax-error g1860)) g1869))) ($syntax-dispatch g1869 (quote (any any . each-any)))))) ($syntax-dispatch g1869 (quote (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 g1869 (quote (any)))))) ($syntax-dispatch g1869 (quote (#(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))))) g1867) ((lambda (g1885) ((lambda (g1886) ((lambda (g1887) ((lambda (g1888) (if g1888 (apply (lambda (g1889) (list (quote #(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 (quote #(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*)) () ())))) g1889)) (list (quote #(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*)) () ())))) (quote #(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*)) () ())))) (quote #(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*)) () ())))) g1886))) g1888) ((lambda (g1890) (if g1890 (apply (lambda (g1891 g1892) (list (quote #(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 (quote #(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*)) () ())))) g1891)) (list (quote #(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*)) () ())))) (quote #(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 g1892 (quote (#(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*)) () ())))))) g1886))) g1890) ((lambda (g1893) (if g1893 (apply (lambda (g1894 g1895 g1896) (list (quote #(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*)) () ())))) g1894 (cons (quote #(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 g1895 g1896)) g1886)) g1893) ((lambda (g1898) (syntax-error g1860)) g1887))) ($syntax-dispatch g1887 (quote (any any . each-any)))))) ($syntax-dispatch g1887 (quote (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 g1887 (quote (any))))) g1867)) g1885)) (g1866 (car g1868) (cdr g1868))))))) g1866) g1864 g1865)) g1862) (syntax-error g1861))) ($syntax-dispatch g1861 (quote (any any . each-any))))) g1860)))($sc-put-cte (quote quasiquote) (letrec ((g1900 (lambda (g1909) (if (identifier? g1909) (free-identifier=? g1909 (quote #(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*)) () ()))))) (quote #f)))) (g1901 (lambda (g1910) (if (identifier? g1910) (free-identifier=? g1910 (quote #(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*)) () ()))))) (quote #f)))) (g1902 (lambda (g1911) (if (identifier? g1911) (free-identifier=? g1911 (quote #(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*)) () ()))))) (quote #f)))) (g1903 (lambda (g1912) ((lambda (g1913) ((lambda (g1914) (if g1914 (apply (lambda (g1915) (g1900 g1915)) g1914) ((lambda (g1916) (quote #f)) g1913))) ($syntax-dispatch g1913 (quote (any ()))))) g1912))) (g1904 (lambda (g1917 g1918) ((letrec ((g1919 (lambda (g1920) (if (null? g1920) g1918 (g1905 (car g1920) (g1919 (cdr g1920))))))) g1919) g1917))) (g1905 (lambda (g1921 g1922) ((lambda (g1923) ((lambda (g1924) (if g1924 (apply (lambda (g1925 g1926) ((lambda (g1927) ((lambda (g1928) (if (if g1928 (apply (lambda (g1929 g1930) (g1900 g1929)) g1928) (quote #f)) (apply (lambda (g1931 g1932) ((lambda (g1933) ((lambda (g1934) (if (if g1934 (apply (lambda (g1935 g1936) (g1900 g1935)) g1934) (quote #f)) (apply (lambda (g1937 g1938) (list (quote #(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 g1938 g1932))) g1934) ((lambda (g1939) (if (null? g1932) (list (quote #(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*)) () ())))) g1925) (list (quote #(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*)) () ())))) g1925 g1926))) g1933))) ($syntax-dispatch g1933 (quote (any any))))) g1925)) g1928) ((lambda (g1940) (if (if g1940 (apply (lambda (g1941 g1942) (g1901 g1941)) g1940) (quote #f)) (apply (lambda (g1943 g1944) (cons (quote #(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 g1925 g1944))) g1940) ((lambda (g1945) (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 #(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*)) () ())))) g1925 g1926)) g1927))) ($syntax-dispatch g1927 (quote (any . any)))))) ($syntax-dispatch g1927 (quote (any any))))) g1926)) g1924) (syntax-error g1923))) ($syntax-dispatch g1923 (quote (any any))))) (list g1921 g1922)))) (g1906 (lambda (g1946 g1947) ((lambda (g1948) (if (null? g1948) (quote (#(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 g1948)) (car g1948) ((lambda (g1949) ((lambda (g1950) (if g1950 (apply (lambda (g1951) (cons (quote #(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*)) () ())))) g1951)) g1950) (syntax-error g1949))) ($syntax-dispatch g1949 (quote each-any)))) g1948)))) ((letrec ((g1953 (lambda (g1954) (if (null? g1954) (if (g1903 g1947) (quote ()) (list g1947)) (if (g1903 (car g1954)) (g1953 (cdr g1954)) (cons (car g1954) (g1953 (cdr g1954)))))))) g1953) g1946)))) (g1907 (lambda (g1955) ((lambda (g1956) ((lambda (g1957) ((lambda (g1958) ((lambda (g1959) (if (if g1959 (apply (lambda (g1960 g1961) (g1900 g1960)) g1959) (quote #f)) (apply (lambda (g1962 g1963) (list (quote #(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 g1963))) g1959) ((lambda (g1965) ((letrec ((g1966 (lambda (g1967 g1968) ((lambda (g1969) ((lambda (g1970) (if (if g1970 (apply (lambda (g1971 g1972) (g1900 g1971)) g1970) (quote #f)) (apply (lambda (g1973 g1974) (g1968 (map (lambda (g1975) (list (quote #(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*)) () ())))) g1975)) g1974))) g1970) ((lambda (g1976) (if (if g1976 (apply (lambda (g1977 g1978) (g1901 g1977)) g1976) (quote #f)) (apply (lambda (g1979 g1980) (g1968 g1980)) g1976) ((lambda (g1982) (if (if g1982 (apply (lambda (g1983 g1984 g1985) (g1902 g1983)) g1982) (quote #f)) (apply (lambda (g1986 g1987 g1988) (g1966 g1988 (lambda (g1989) (g1968 (cons g1987 g1989))))) g1982) ((lambda (g1990) (list (quote #(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*)) () ())))) g1957)) g1969))) ($syntax-dispatch g1969 (quote (any any any)))))) ($syntax-dispatch g1969 (quote (any . each-any)))))) ($syntax-dispatch g1969 (quote (any each-any))))) g1967)))) g1966) g1955 (lambda (g1991) (cons (quote #(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*)) () ())))) g1991)))) g1958))) ($syntax-dispatch g1958 (quote (any each-any))))) g1957)) g1956)) g1955))) (g1908 (lambda (g1992 g1993) ((lambda (g1994) ((lambda (g1995) (if g1995 (apply (lambda (g1996) (if (= g1993 (quote 0)) g1996 (g1905 (quote (#(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*)) () ()))))) (g1908 (list g1996) (- g1993 (quote 1)))))) g1995) ((lambda (g1997) (if g1997 (apply (lambda (g1998 g1999) (if (= g1993 (quote 0)) (g1904 g1998 (g1908 g1999 g1993)) (g1905 (g1905 (quote (#(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*)) () ()))))) (g1908 g1998 (- g1993 (quote 1)))) (g1908 g1999 g1993)))) g1997) ((lambda (g2002) (if g2002 (apply (lambda (g2003 g2004) (if (= g1993 (quote 0)) (g1906 g2003 (g1908 g2004 g1993)) (g1905 (g1905 (quote (#(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*)) () ()))))) (g1908 g2003 (- g1993 (quote 1)))) (g1908 g2004 g1993)))) g2002) ((lambda (g2007) (if g2007 (apply (lambda (g2008) (g1905 (quote (#(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*)) () ()))))) (g1908 (list g2008) (+ g1993 (quote 1))))) g2007) ((lambda (g2009) (if g2009 (apply (lambda (g2010 g2011) (g1905 (g1908 g2010 g1993) (g1908 g2011 g1993))) g2009) ((lambda (g2012) (if g2012 (apply (lambda (g2013) (g1907 (g1908 g2013 g1993))) g2012) ((lambda (g2015) (list (quote #(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*)) () ())))) g2015)) g1994))) ($syntax-dispatch g1994 (quote #(vector each-any)))))) ($syntax-dispatch g1994 (quote (any . any)))))) ($syntax-dispatch g1994 (quote (#(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 g1994 (quote ((#(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 g1994 (quote ((#(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 g1994 (quote (#(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))))) g1992)))) (lambda (g2016) ((lambda (g2017) ((lambda (g2018) (if g2018 (apply (lambda (g2019 g2020) (g1908 g2020 (quote 0))) g2018) (syntax-error g2017))) ($syntax-dispatch g2017 (quote (any any))))) g2016))))($sc-put-cte (quote include) (lambda (g2021) (letrec ((g2022 (lambda (g2023 g2024) ((lambda (g2025) ((letrec ((g2026 (lambda () ((lambda (g2027) (if (eof-object? g2027) (begin (close-input-port g2025) (quote ())) (cons (datum->syntax-object g2024 g2027) (g2026)))) (read g2025))))) g2026))) (open-input-file g2023))))) ((lambda (g2028) ((lambda (g2029) (if g2029 (apply (lambda (g2030 g2031) ((lambda (g2032) ((lambda (g2033) ((lambda (g2034) (if g2034 (apply (lambda (g2035) (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")) #(ribcage ((import-token . *top*)) () ())))) g2035)) g2034) (syntax-error g2033))) ($syntax-dispatch g2033 (quote each-any)))) (g2022 g2032 g2030))) (syntax-object->datum g2031))) g2029) (syntax-error g2028))) ($syntax-dispatch g2028 (quote (any any))))) g2021))))($sc-put-cte (quote unquote) (lambda (g2037) ((lambda (g2038) ((lambda (g2039) (if g2039 (apply (lambda (g2040 g2041) (syntax-error g2037 (quote "expression not valid outside of quasiquote"))) g2039) (syntax-error g2038))) ($syntax-dispatch g2038 (quote (any . each-any))))) g2037)))($sc-put-cte (quote unquote-splicing) (lambda (g2042) ((lambda (g2043) ((lambda (g2044) (if g2044 (apply (lambda (g2045 g2046) (syntax-error g2042 (quote "expression not valid outside of quasiquote"))) g2044) (syntax-error g2043))) ($syntax-dispatch g2043 (quote (any . each-any))))) g2042)))($sc-put-cte (quote case) (lambda (g2047) ((lambda (g2048) ((lambda (g2049) (if g2049 (apply (lambda (g2050 g2051 g2052 g2053) ((lambda (g2054) ((lambda (g2055) (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")) #(ribcage ((import-token . *top*)) () ())))) (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")) #(ribcage ((import-token . *top*)) () ())))) g2051)) g2055)) g2054)) ((letrec ((g2056 (lambda (g2057 g2058) (if (null? g2058) ((lambda (g2059) ((lambda (g2060) (if g2060 (apply (lambda (g2061 g2062) (cons (quote #(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 g2061 g2062))) g2060) ((lambda (g2064) (if g2064 (apply (lambda (g2065 g2066 g2067) (list (quote #(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 (quote #(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*)) () ())))) (quote #(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 (quote #(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*)) () ())))) g2065)) (cons (quote #(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 g2066 g2067)))) g2064) ((lambda (g2070) (syntax-error g2047)) g2059))) ($syntax-dispatch g2059 (quote (each-any any . each-any)))))) ($syntax-dispatch g2059 (quote (#(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))))) g2057) ((lambda (g2071) ((lambda (g2072) ((lambda (g2073) ((lambda (g2074) (if g2074 (apply (lambda (g2075 g2076 g2077) (list (quote #(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 (quote #(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*)) () ())))) (quote #(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 (quote #(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*)) () ())))) g2075)) (cons (quote #(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 g2076 g2077)) g2072)) g2074) ((lambda (g2080) (syntax-error g2047)) g2073))) ($syntax-dispatch g2073 (quote (each-any any . each-any))))) g2057)) g2071)) (g2056 (car g2058) (cdr g2058))))))) g2056) g2052 g2053))) g2049) (syntax-error g2048))) ($syntax-dispatch g2048 (quote (any any any . each-any))))) g2047)))($sc-put-cte (quote identifier-syntax) (lambda (g2082) ((lambda (g2083) ((lambda (g2084) (if g2084 (apply (lambda (g2085 g2086) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ())))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ()))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ())))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ())))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ())))) (quote (#(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 (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ())))) g2086)) (list (cons g2085 (quote (#(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 (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ())))) (cons g2086 (quote (#(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*)) () ()))))))))))) g2084) ((lambda (g2087) (if (if g2087 (apply (lambda (g2088 g2089 g2090 g2091 g2092 g2093) (if (identifier? g2089) (identifier? g2091) (quote #f))) g2087) (quote #f)) (apply (lambda (g2094 g2095 g2096 g2097 g2098 g2099) (list (quote #(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*)) () ())))) (quote (#(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 (quote #(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*)) () ())))) (quote (#(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 (quote #(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*)) () ())))) (quote #(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*)) () ())))) (quote (#(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 (quote #(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*)) () ())))) g2097 g2098) (list (quote #(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*)) () ())))) g2099)) (list (cons g2095 (quote (#(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 (quote #(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 g2096 (quote (#(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 g2095 (list (quote #(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 (quote #(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*)) () ())))) g2095)) (list (quote #(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*)) () ())))) g2096)))))) g2087) (syntax-error g2083))) ($syntax-dispatch g2083 (quote (any (any any) ((#(free-id #(syntax-object set! ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ((import-token . *top*)) () ())))) any any) any))))))) ($syntax-dispatch g2083 (quote (any any))))) g2082))) \ No newline at end of file diff --git a/module/language/r5rs/psyntax.ss b/module/language/r5rs/psyntax.ss new file mode 100644 index 000000000..0e8747b38 --- /dev/null +++ b/module/language/r5rs/psyntax.ss @@ -0,0 +1,3197 @@ +;;; 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 : " +;;; +;;; (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